How can copy a shape along with the cell it is in? When I copy manually the shape follows the cell, but when I do it with a macro I get everything else but the shape.
Cells(sourceRow, sourceColumn).Copy
Cells(targetRow, targedColumn).PasteSpecial
...
Range("A1").copy
Range("B2").PasteSpecial Operation:=xlPasteAll
I've tried all I could think of... but the shape just won't move.
Recorded the manual copy/paste and this is what I got:
Range("A1").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
I would do something like this to avoid having to actually select the cell:
Sub MoveShape()
Dim s As Shape
Dim T, L, celWidth, shpWidth, celHeight, shpHeight As Double
Dim rng As Range
Dim ws as Worksheet
Set s = ws.Shapes(1).Duplicate ''You'll have to get the index of the shape you want to copy
Set rng = Range("A3") ''Set this to your target range
T = rng.Top
L = rng.Left
celWidth = rng.Width
shpWidth = s.Width
celHeight = rng.Height
shpHeight = s.Height
s.Top = T + (celHeight - shpHeight) / 2
s.Left = L + (celWidth - shpWidth) / 2
End Sub
This will duplicate your shape, and put the resulting clone in the centre of your target range. You can change its position in the cell by modifying the s.Left and s.Top values.
You can now use Range("A3").Value = Range("A1").Value to copy the actual values of the cell to your target range
Try this
Range("A1").Select
Selection.Copy
Range("B1").Select
ActiveSheet.Paste
Related
I’ve a routine that effectively pastes a link to a cell or cells that a user has copied to the clipboard, putting a space after the "=" (a personal preference, for readability) and changing the anchoring to row-only before pasting. If the link is to another sheet, the font is changed to blue. The code is as follows:
Sub QuickLink2()
' Copies a link,putting a space after the "=" and changing the
' anchoring to row-only. If the link is to another sheet, the
' font is changed to blue.
Dim r As Long, c As Long
Dim FormulaArr() As Variant
Dim Destination As Range
Application.ScreenUpdating = False
' Paste link
On Error Resume Next
ActiveSheet.Paste Link:=True
If Err.Number = 1004 Then GoTo NoSelection '1004 is a paste failure
On Error GoTo 0
' Transfer pasted link to array
If Selection.Cells.Count = 1 Then
ReDim FormulaArr(1 To 1, 1 To 1)
FormulaArr(1, 1) = Selection.Formula
Else
FormulaArr = Selection.Formula
End If
' Adjust formula spaces and anchoring
For r = 1 To UBound(FormulaArr, 1)
For c = 1 To UBound(FormulaArr, 2)
FormulaArr(r, c) = Replace(FormulaArr(r, c), "=", "= ")
FormulaArr(r, c) = Application.ConvertFormula _
(FormulaArr(r, c), xlA1, xlA1, xlAbsRowRelColumn)
Next c
Next r
Set Destination = Selection
Destination.Formula = FormulaArr
' Change font to blue if link is to another sheet
If Destination(1).Formula Like "*!*" Then _
Destination.Font.Color = RGB(0, 0, 255)
Exit Sub
NoSelection:
Application.CutCopyMode = False
End Sub
The idea here is to speed up the code by assigning the pasted link to a variant array, doing the necessary work on the array, and then assigning the array to a range. What I really want to do, however, is to access the copied cell formulas directly from the clipboard, and assign to the variant array without the intermediate ActiveSheet.Paste Link:=True step.
The following code would allow me to get the copied cell value, but of course I'm looking for the copied formulas.
Dim DataObj As New MSForms.DataObject
Dim S As String
DataObj.GetFromClipboard
S = DataObj.GetText
To get formula's:
Private Sub PutCellFormulaInClipBoard(ByVal Cell As Range)
Dim oDataObject As Object
Set oDataObject = _
GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With oDataObject
.Clear
.SetText Cell.Cells(1).Formula
.PutInClipboard
End With
End Sub
Ref
I'm trying to create a excel file where I will have shapes.
That shapes i'm trying to connect to cell values.
So when I click on button start, excel will go through the cell values, of cell value is X, I want shape X to blink red, and if cell value is Y cell will be green.
For now i programmed code for going through cells in one column and changing its color to green and red:
Sub test()
Dim sh As Shape
Dim area As String
Set sh = Sheet1.Shapes("X")
Range("A1").Select
Do Until ActiveCell.Value = ""
area = ActiveCell.Value
If area = "X" Then
sh.Fill.ForeColor.RGB = rgbRed
End If
ActiveCell.Offset(1, 0).Select
Loop End Sub
I have a problem with programming the code to change the name of cell and to change the color of other shapes.
You have to wait about 1 second between the selection of the cells in order to make it work. With your code and using Select Cell, something like this should work:
Sub test()
Dim sh As Shape
Dim area As String
Set sh = ActiveSheet.Shapes("X")
Range("A1").Select
Do Until ActiveCell.Value = ""
area = ActiveCell.Value
If area = "X" Then
sh.Fill.ForeColor.RGB = rgbRed
Application.Wait Now + #12:00:01 AM#
ElseIf area = "Y" Then
sh.Fill.ForeColor.RGB = rgbGreen
Application.Wait Now + #12:00:01 AM#
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
In general, using Select in VBA is considered a bad practice, but in this case it makes the "application" look better, because you can follow the current cell.
I have an array of sheet names. I want to copy data from another file and paste the data in the respective worksheet. But it doesn't find the sheet. It creates an error in this step:
worksheets.(sheets(i)).Activate
Here is my code:
Sub NewWorkshet()
Dim criteria(40) As Integer
Dim i As Integer
Dim MyFile As String
MyFile = Application.GetOpenFilename()
criteria(0) = 335
criteria(1) = 336
criteria(2) = 337
criteria(3) = 338
criteria(4) = 339
criteria(5) = 351
criteria(6) = 392
criteria(7) = 393
Dim sheets As Variant
sheets = Array(a335, a336, a337, a338, a339, a351, a392, a393)
For i = 0 To 7
' Remove Filter
Windows("firstbook.xlsx").Activate
ActiveSheet.Range("$A$1:$S$6274").AutoFilter Field:=17
Workbooks.Open (MyFile)
Worksheets("first").Select
ActiveSheet.Range("$A$1:$O$3339").AutoFilter Field:=2, Criteria1:=criteria(i)
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("firstbook").Activate
Worksheets("sheets(i)").Select
Range("B2").Select
Selection.End(xlDown).Select
Selection.Offset(1, -1).Select
ActiveSheet.Paste
Workbooks(MyFile).Close SaveChanges:=False
Next i
End Sub
Its treating Worksheets("sheets(i)").Select literally as a word sheets(i) not as a variable. So it wont change and it will not find your sheet.
You need to create a string for this.
Try add Dim MySheet As String
then use this in loop:
MySheet = "sheets(" & i & ")"
Then MySheet can be referenced and will change as you want.
Your issue is that you haven't set your 'sheets' values as text.
sheets = Array(a335, a336, a337, a338, a339, a351, a392, a393)
The code should read
Dim sheets(0 To 7) As Variant
sheets(0) = "a335"
sheets(1) = "a336"
sheets(2) = "a337"
sheets(3) = "a338"
sheets(4) = "a339"
sheets(5) = "a351"
sheets(6) = "a392"
sheets(7) = "a393"
Then refer as follows;
Worksheets(sheets(i)).Select
The issue is that
Worksheets("sheets(i)").Select
is looking for a worksheet called "sheets(i)" as a text/name.
If you use instead
Worksheets(sheets(i)).Select
then it is looking for a workhseet called like the value of the variable/array sheets(i)
I am not a Dev, but given I do use Excel, I have been tasked to create a looping macro that will check for a string ('Resource') in a cell and if it finds that string, then run a Copy and Paste code and then move to the next row. This starts at row 5 and runs continuously until row 199, but does not work on every row, hence the validation for the string Resource.
I have managed to create the macro for the Copy and Paste but it also has issues as I created it using the macro recorder and it only works on the row I actually did the recording on.
I am at a complete loss, can anyone help?
this is what I have so far
A New Resource name is added manually to the spreadsheet
the user clicks cell (C6) to focus the curser
the user clicks a macro button called 'Forecast for Future Project 1' to start the macro
On the button click the Macro will:
Interogate if cell to the left of current cell (B6) = 'Resource'
IF Yes, THEN
Sub CP()
DO
Range("C6").Select
Selection.Copy
Application.Goto Reference:="ProjAdd"
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=SUMIF('Current Project Utilisation'!R2C1:R62C1,RC1,'Current Project Utilisation'!R2C:R62C)+SUMIF('Future Project 1'!R2C1:R62C1,RC1,'Future Project 1'!R2C:R62C)"
Range("ProjAdd").Select
Selection.Copy
Range("C6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Paste
Range("B6").Select
Loop Until ActiveCell.Address(0,0) = "$B$199"
End Sub
Move to cell under original active cell (C7) and Repeat the Macro until cell C199 is reached
If (B6) does not = 'Resource' then move to go to the cell under (C7) aand Repeat the Macro until cell C199 is reached
Refresh Worksheet to update data
Would something like this work for you?
Sub CopyPasteResource()
Dim CopyRange As Range
Dim Cell As Range
Set CopyRange = Workbooks("YourWorkBookName").Sheets("Sheet1").Range("C6:C199")
For Each Cell In CopyRange
If InStr(1, Cell.Offset(0, -1).Text, "Resource") Then
Cell.Copy
'paste where you wish
End If
Next Cell
End Sub
EDIT: Or do you want to loop through B6:B199 and then C6:199? I'm not entirely clear on the aim.
Ah the old macro recorder, generating 90% extra code since 1997. I couldn't exactly figure out from your question what exactly is being copied and to where but this code will loop through rows 5 to 199, check if the value in column B = "Resource" and then set the corresponding value in column C, you should be able to modify for your needs but I think you definitely want a structure more like this than what the recorder generated for you..
public sub cp()
Dim ws as Worksheet
Set ws = Worksheets("Current Project Utilisation")
Dim i as int
for iI = 5 to 199
if(ws.cells(i, 2).value = "Resource") then
ws.cells(i, 3).value = "what you're copying"
end if
next I
end sub
Assuming your cell range doesn't change you can do this for the looping part
Sub ResourceCheck()
Dim WS As Worksheet
Set WS = ActiveSheet
Dim Resources() As Long, r As Long
ReDim Resources(5 To 199)
For r = 5 To 199
If UCase(WS.Cells(r, 2).Value) = "RESOURCE" Then
WS.Cells(r, 3).Value = "x"
'Do copy paste part
End If
Next r
Application.Calculate
End Sub
Can you add a sample of your data? It's a bit hard to see what you're referencing to and how the data relates to each other.
Also, where is the "Projadd" cell reference? And what does it do?
Sub CP()
' I like to know what worksheet I'm on
Dim ws as Worksheet
' if it's a dedicated worksheet use this
' Set ws = ThisWorkbook.Worksheets("Sheet1")
' Otherwise following your current code
Set ws = ActiveSheet
' I also like to grab all my data at once
Dim Data as Variant
Data = ws.Range("B6:B199")
' No need to focus the cursor
For row = 5 to 199
' No need to select any range
' Is this case-sensitive???
If Data(row-4, 1) = "Resource" Then
' Copy C6??? Paste 'ProjAdd'
ws.Cells(row, 3).Copy Range("ProjAdd")
Application.CutCopyMode = False
End If
Next
End Sub
I have the base column with the checkbox, (the D column in my code), and i want to copy that column with the checbox to the other columns, but the column D must be hide(all the data including the checkbox).
the problem here is:
i don't know how to hide the checbox, when i hide the column the checbox still visible.
when i coppy the column the checbox in the colum does not be copied
This is the fuction that i actually used.
Private Sub cmdAddNewXref_Click()
Columns("D:D").Select
Selection.Copy
i = 3
Cells(2, i).Select
Do
i = i + 1
Loop While Cells(2, i) <> ""
Cells(2, i).Select
'MsgBox ActiveCell.Column
Columns(i - 1).Select
Columns("D:D").Select
Selection.Copy
Columns(i).Select
ActiveSheet.Paste
Selection.EntireColumn.Hidden = False
Application.CutCopyMode = False
Range("A1").Select
End Sub
but most importantly what i want to do, is possible?
EDIT 1: actually thanks to Scott Holtzman i can hide the checkbox with the columns.
Give this is a shot. There's probably a bit more of ideal way to do it, but I tested it and got it to work.
There are some assumptions on cell ranges and such that you will need to adjust to meet your exact spreadsheet specs.
Option Explicit
Private Sub cmdAddNewXref_Click()
Dim i As Integer
Dim ws As Worksheet
Set ws = Worksheets("mySheet") 'change as needed
'find next column to copy
i = 3
Do
i = i + 1
Loop While ws.Cells(2, i) <> ""
With ws.Columns("D:D")
.EntireColumn.Hidden = False
.Copy Columns(i)
End With
'copy checkbox in column D
Dim cb As Shape
Set cb = ws.Shapes("CheckBox1") 'change name as needed
cb.Copy
ws.Cells(4, i).Select 'assumes checkbox should be in row 4, change to wherever it is on column D for you
ws.Paste
ws.Columns("D:D").EntireColumn.Hidden = True
End Sub
CHange the paste, to paste special values, to hide the check its the .visible property I believe.
hope this helps.
From what I gathered... Copying the row, to somewhere else, but not the control, then he wanted to hide copied row. :)
Option Explicit
Sub test()
' From above code in yours I will be col number
Dim i As Integer
i = 5
Columns("A:A").Copy
Sheet2.Activate
ActiveSheet.Cells(1, i).PasteSpecial xlPasteValues
End Sub