I have a worksheet containing 35 columns of formulas which looks up data from another worksheet. Every time data is entered into the lookup worksheet ("Data") I want to add another set of formulas to the bottom of the row. I've managed to get the code to copy the correct formulas over these 35 columns, to the correct location at the bottom. But when they paste, the exact text of the formulas is copied, rather than changing the cells referenced.
e.g. formula "=OFFSET(Data!$B$1,(A7736-1)*34,0)" copied from row 7736 into row 8300 should become =OFFSET(Data!$B$1,(A8300-1)*34,0) but stays as "=OFFSET(Data!$B$1,(A7736-1)*34,0)"
This is my code
Dim workbk As Workbook
Dim databk As Workbook
Dim MRD As Worksheet
Dim formularrange As Range
Dim lasttrayname As String
Dim datarow As Long
Dim nrow As Long
Dim loopcount As Long
Dim urow As Long
Set workbk = ActiveWorkbook
'set Macro recording information sheet
Set MRD = Worksheets("Macro RunDate")
'find last date updated
urow = Worksheets("Macro RunDate").Range("A" & Rows.Count).End(xlUp).Row
'find last tray used
lasttray = MRD.Range("B" & urow).Value
'find row to paste raw tray data
datarow = Worksheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Do while *condition*
'...More code here....
Loopcount = 0
Loopcount = loopcount + 34
Loop
Go to Tidy:
Tidy:
If loopcount > 0 Then
'convert to correct number of rows to copy
loopcount = (loopcount)/34*8
'copy formulas in Sheet2 for correct number of trays
'determine end row by finding "lasttray"
nrow = Worksheets("Sheet2").Range("A:A").Find(What:=lasttray, _
SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlNext).Row + 8
'repeat formulas
Worksheets("Sheet2").Range(Cells(nrow + 1, "A"), Cells(nrow + loopcount + 1, _
"S")).Formula = Worksheets("Sheet2").Range("A3975:s" & 3975 + loopcount).Formula
'calculate formula values
Worksheets("Sheet2").Range("A:E").Calculate
End If
So my question is, how do I copy these formulas and get the references to change?
Thanks in advance
Instead of setting the Formula property, you could use Copy:
Dim Source As Range
Dim Dest As Range
Set Source = Worksheets("Sheet2").Range("A3975:s" & 3975 + loopcount)
Set Dest = Worksheets("Sheet2").Range(Cells(nrow + 1, "A"), Cells(nrow + loopcount + 1, _
"S"))
Source.Copy Dest
Excel will then increment the row numbers just as it would when copying manually.
Use .FormulaR1C1 rather than .Formula.
– From the comment by #Rory Jun 4 '14 at 13:16
Instead of using cell1 = cell2, do the following:
Range(cell1).Select
Application.CutCopyMode = False
Selection.Copy
Range(cell2).Select
ActiveSheet.Paste
That should paste the relative formula.
Related
I have a spreadsheet with values starting at A5 and running across to column AI, there could be any number of entries to the rows.
Row A contains an Item code (e.g. 000-0000)
I am looking to produce some code to complete the following two actions:
If column AI = yes, then copy entire row and paste below. With every copy add a sequential alphabetised letter to the code in column A (e.g. 000-0000a)
Any help would be greatly appreciated. Everything i've found expands to copying to another sheet and i'm struggling to break down the code.
Thanks
Edit:
Please see below current code I have been trying to get to work which works up to the point of copying the row however fails to paste it.
Sub NewItems(c As Range)
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells
objWorksheet.Select
If rngCell.Value <> "Yes" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
So there are lots of things to address with your code. Many of which I have touched on. But the main thing to observe is that you are testing Column A not Column AI for the presence of "Yes" - so there may not be a match hence no copy.
As the paste destination is determined by a concatenation to create a sheet name you should have a test to ensure that sheet exists.
For testing I simply ensured a sheet called Sheet1a existed, that Sheet1 cell A5 had "a" in it, and there was a "Yes" in column AI. This could be improved but is enough to get you going.
This line is looping column A:
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Whereas this line is testing column AI:
If rngCell.Offset(, 35).Value <> "Yes"
Note <> means Not Equal as opposed to =
So perhaps you wanted:
If rngCell.Offset(, 35).Value = "Yes"
Consider the following re-write.
Option Explicit
Public Sub NewItems() 'c As Range) 'I have commented out parameter which isn't currently used.
Dim rngBurnDown As Range ' not used but also not declared
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim lastRowTargetSheet As Long
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim lastRow As Long
lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Dim copiedRange As Range 'for union
For Each rngCell In rngNewItems.Cells
'Debug.Print rngCell.Address 'shows where looping
If rngCell.Offset(, 35).Value = "Yes" Then
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
Dim nextTargetCell As Range
lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)
rngCell.EntireRow.Copy nextTargetCell
Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
lastRowTargetSheet = 0
Set nextTargetCell = Nothing
End If
Next rngCell
objWorksheet.Cells(1, 1).Select
End Sub
As for your lettering:
There are lots of examples online to generate these. Here is one way, by #harfang, from here:
Sub List_A_to_ZZZZ()
Dim i As Long
For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
Debug.Print Right("---" & XLcL(i), 4)
Next i
End Sub
Function XLcL(ByVal N As Long) As String
Do While N > 0
XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
N = (N - 1) \ 26
Loop
End Function
Function ColXL(ByVal abc As String) As Long
abc = Trim(Replace(UCase(abc), "-", ""))
Do While Len(abc)
ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
abc = Mid(abc, 2)
Loop
End Function
I've been working on a Macro that i need to copy, concatenate what has been selected through the counter. e.g. is below
excel snapshot example
so what i want to do is set a count in column c from 1 to "infinite" because each worksheet varies to go up to 10 or hundreds and when the counter hits a value of 1 again to stop concatenate column D what is in the range from 1 to "the last digit it stopped before hitting 1 again" and paste it on a different sheet. I know little to nothing on VBA but I understand the copy and paste to different sheet part. I'm just stuck on the counter and the concatenate part. Here is the code i have so far(i edited it to resemble the example for better reference)
'select counter/concatenate
Sheets(1).Select
Columns("C").EntireColumn
Do
Columns("C").Count
For i = 1 To 9999
Loop While (i <= 1)
If i = 1 Then
select.columns("D")
after the count is where i am stuck. this count is what I've come up with looking at different variations of counters.
I suggest you Forget about column and use just one cell for easier understanding. A cell is a reference that allows you to refer to any other cells on the sheet by using Offsets. You may use two Loops, the outer one crawling the columns, the inner one working downward until it finds 1
Dim i As Long ' note that in VBA integer Overflows at 65535 rows
Dim s As String
Set aCell = Worksheet("Sheet1").Range("D1")
While aCell.Column < 255
i = 0
s = ""
While Not aCell.Offset(i, 0).Value = 1
s = s & aCell.Offset(1, 0).Value
Wend
' paste s somewhere by using range.value = s
Set aCell = aCell.Offset(0, 1)
Wend
By specifying the workbook and worksheet before the range, you may refer to the proper cell without being dependent on the active worksheet or range.
Hope this works for you.
You can try this (not tested):
Dim s As String, firstAddr as String
Dim f as range, iniCell As Range
With Worksheet("MySheet") '<--| change "MySheet" to your actual sheet name
With .Range("C1", .Cells(.Rows.Count, 3).End(xlUp))
Set f = .Find(What:=1, LookAt:=xlWhole, LookIn:=xlValues, After:=.Cells(.Rows.Count, 1))
If Not f Is Nothing Then
firstAddr = f.Address
Set iniCell = f
Set f = FindNext(f)
Do While f.Address <> firstAddr
s = s & Join(Range(iniCell, f.Offset(-1)).Offset(, 1), "")
' here code to paste s somewhere
Set iniCell = f
Set f = FindNext(f)
Loop
End If
End With
End With
Here's one I actually tested, using some random data in columns C and D.
You'll have to modify a little to get exactly where you want the data to go, but should get you in the right direction.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
Dim s As String
Dim lastRow As Long
Dim c As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = ws1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'This will get an accurate last row
c = 1
For i = 1 To lastRow
s = s & ws1.Cells(i, 4).Value 'Build the string
If ws1.Cells(i + 1, 3).Value = 1 Or ws1.Cells(i + 1, 3).Value = "" Then
ws2.Cells(c, 1).Value = s
s = ""
c = c + 1
'If the next cell to check is 1 or blank, then copy the values to the next cell in order on sheet2
End If
Next
End Sub
Walking through it, lastRow is set using the last row in the sheet with a value in it. Then, c is set to one, although you could set this to the last available row in ws2 using the same process. After that it just steps through the rows from 1 To LastRow building strings and transferring the value to ws2 when it's about to hit a 1.
the thing is I want to copy a certain column but I want to only copy data on a specific cell and get the data below it.
Let say for example, I want to copy Cell C5 and below, this will disregard C1 to C4. Is this possible?
Further to my comments below your question, here is one way. This will work in all scenarios. Whether you have blank cells or not...
Option Explicit
Sub CopyCells()
Dim ws As Worksheet
Dim rng As Range
Dim sRow As Long, lRow As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
sRow = 5 '<~~ Starting row
With ws
'~~> Find last row in Col C
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> If the last row < Start Row
If lRow < sRow Then
MsgBox "Start Row cannot be greater then last row"
Else
'~~> Create your range
Set rng = .Range("C" & sRow & ":C" & lRow)
'~~> Copy
rng.Copy
'
' Do what you want with copied data
'
End If
End With
End Sub
Sheet1.Columns(3).Resize(Sheet1.Columns(3).Rows.Count - 4).Offset(4).Select
This will select entire C column but first 4 cells. It simply take column 3, resize it to subtract first 4 cells and offset the starting cell 4 cell below and select that range.
If your range is defined then code could be more optimized.
EDIT for sample code:
Sub copyCells()
Dim sht As Worksheet
Dim rngStart As Range
Dim rng As Range
Set sht = Sheet1
Set rngStart = sht.Cells(5, 3) ' this is C5
rngStart.Select
Set rng = rngStart.Resize(rngStart.End(xlDown).Row - rngStart.Row + 1)
rng.Copy Sheet2.Cells(1, 1) ' copy where you need
End Sub
This will copy a entire column (with data) from selection, just paste it wherever you want.
Sub CopyColumnFromSelected()
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End Sub
Or (Ctrl + Shift + down arrow) <--- from your desired cell and Ctrl+C ;)
I am trying to use a macro to clean up data files and only copy on Sheet2 what is most relevant.
I have written the code to find the row I want the data to be copied from. However I can only copy the row itself and not the range underneath. Please note I need the range to go from that row to the last column and last row as the size of the matriz always varies.
s N s N s N s N s rpm
Linear Real Linear Real Linear Real Linear Real Linear Amplitude
0.0000030 9853.66 0.0000030 5951.83 0.0000030 533.48 0.0000030 476.15 0.0000030 2150.16
0.0000226 9848.63 0.0000226 5948.19 0.0000226 557.02 0.0000226 488.60 0.0000226 2150.16
0.0000421 9826.05 0.0000421 5956.22 0.0000421 615.94 0.0000421 480.75 0.0000421 2150.15
0.0000616 9829.72 0.0000616 5989.72 0.0000616 642.59 0.0000616 476.77 0.0000616 2150.15
So basically the code below finds that first row and copies it in Sheet2. I need the macro to also select the range underneath and copy it onto Sheet2. Please can you help me finishing off the script?
Sub SearchForRawData()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
'If value in column A = "s", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = "s" Then
'Select row and range in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Select all Raw Data underneath found Row to Copy
'Paste all Raw Data into Sheet 2
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error has occured"
End Sub
You don't need a loop for this if you want to copy the row that has the "s" and everything below it to the target sheet. The following sub finds the row with the "s" in column A and then copies that row and everything below it to the target sheet.
Note that you should always avoid selecting or activating anything in VBA code, and that the normal way to copy and paste relies on selecting. If you use the syntax I've included here, the clipboard is not used and the target sheet does not need to be selected.
Sub CopyRowAndBelowToTarget()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim match As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
Dim lastCopyRow As Long
Dim lastPasteRow As Long
Dim lastCol As Long
Dim matchRow As Long
Dim findMe As String
' specify what we're searching for
findMe = "s"
' find our search string in column A (1)
Set match = src.Columns(1).Find(What:=findMe, After:=src.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' figure out what row our search string is on
matchRow = match.Row
' get the last row and column with data so we know how much to copy
lastCopyRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
' find out where on our target sheet we should paste the results
lastPasteRow = tgt.Range("A" & src.Rows.Count).End(xlUp).Row
' use copy/paste syntax that doesn't use the clipboard
' and doesn't select or activate
src.Range(Cells(matchRow, 1), Cells(lastCopyRow, lastCol)).Copy _
tgt.Range("A" & lastPasteRow)
End Sub
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
So firstly you don't acutally need the CStr, vba will cast numbers to strings by itself, i.e. Range(LSearchRow & ":" & LSearchRow) should work fine.
To find how many rows down to go use the end function of the range object:
bottomRow = Range("A" & LSearchRow).End(xldown).Row
Do the same for the column
lastCol = Range("A" & LSearchRow).End(xlleft).column
Now to copy:
Range("A" & LSearchRow & ":" & lastCol & bottomRow).Copy
However if you have empty cells inthe middleof the data then instead of using End(xldown), start at the bottom of the sheet and look up:
bottomRow = Range("A1000000").End(xlup).Row
etc
I'm new with VBA and I'm stuck somewhere. I have to copy last row of column A till column H and paste it untill the last row of column I. Last rows of columnns will be always change.
e.g; my data is in A2:H2 and I5 is the last cell with data.
My code should be copy A2:H2 and paste it A3:H5. And second time I run the macro (after I add new data to respective columns) it should be copy A6:H6 and paste it untill the last row of column I.
I wrote two codes which were not fulfill my needs.
first code is;
Sub OrderList1()
Range("a65536").End(xlUp).Resize(1, 8).Copy _
(Cells(Cells(Rows.Count, 9).End(xlUp).Row, 1))
End Sub
this code skips A3:H4 and only pastes to A5:H5
second code is;
Sub OrderList2()
Range("A2:H2").Copy Range(Cells(2, 8), _
Cells(Cells(Rows.Count, 9).End(xlUp).Row, 1))
End Sub
it copies A2:H3 and paste it A5:H5 but when I add new data it doesn't start to paste from A5:H5. It start from A2:H2 and overwrite to old data.
I can see what I have to change,range should be dynamic range like in the first code,but I can't manage to write the code.
I'll really appreciate little help.
You might want to use this as a starting point:
Dim columnI As Range
Set columnI = Range("I:I")
Dim columnA As Range
Set columnA = Range("A:A")
' find first row for which cell in column A is empty
Dim c As Range
Dim i As Long
i = 1
For Each c In columnA.Cells
If c.Value2 = "" Then Exit For
i = i + 1
Next c
' ok, we've found it, now we can refer to range from columns A to H of the previous row
' to a variable (in the previous row, column A has not been empty, so it's the row we want
' to copy)
Dim lastNonEmptyRow As Range
Set lastNonEmptyRow = Range(Cells(i - 1, 1), Cells(i - 1, 8))
' and now copy this range to all further lines, as long as columnI is not empty
Do While columnI(i) <> ""
lastNonEmptyRow.Copy Range(Cells(i, 1), Cells(i, 8))
i = i + 1
Loop
Try this one for something that allows future functionality, or at least it did for me...Ask if you need help understanding it :)
Option Explicit
Sub lastrow()
Dim wsS1 As Worksheet 'Sheet1
Dim lastrow As Long
Dim lastrow2 As Long
Set wsS1 = Sheets("Sheet1")
With wsS1
'Last row in A
lastrow = Range("A" & Rows.Count).End(xlUp).Row
'Last Row in I
lastrow2 = Range("I" & Rows.Count).End(xlUp).Row
'Cut in A:H and paste into last row on I
wsS1.Range("A2:H" & lastrow).Cut wsS1.Range("I" & lastrow2)
End With
End Sub