I have data on Sheet1 which varies in quantity. And I need a macro to loop through all the range if if the cell has a value, then copy it to a specific column on Sheet2. I cannot simply copy the whole range for reasons I won't get into. I need to loop through each cell one by one and paste the value in a specific format on Sheet2.
I have the below code, which gives me
Error '1004' Method 'Range of Object'_Worksheet' failed.
Sub COPY()
Dim i As Long, j As Long, rng As Range, k As Long, ws1 As Worksheet, ws2 As Worksheet
k = 1
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = Range("B4:D17")
For i = 1 To rng.Rows.Count
If Not IsEmpty(rng.Cells(i, 1)) Then
ws1.Range(rng.Cells(i, 3)).Copy Worksheets("Sheet2").Range("A1")
End If
Next
End Sub
Forget the rng object altogether. It would be more necessary in a For Each statement, but you are simply looping through rows in your sheet.
Create a simple For i statement that just loops the rows you need:
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim i As Long
For i = 4 To 17
If Not IsEmpty(ws1.Cells(i, 2)) Then
ws1.Cells(i, 4).Copy ws2.Range("A1")
End If
Next i
As I've already pointed out, your copy destination ws2.Range("A1") is static, so everytime your criteria is met it continues to overwrite your data here. But you seem to have that handled so I won't assume what you are trying to do with it.
Related
I have written a code in which I try to copy and paste several ranges of data from one worksheet to the other, but I want to copy the data below the previous set of data. The code I used for the copy entries is this part:
Selection.Copy
Windows(Workbook1).Activate
Sheets(Sheet1).Select
Cells(Rows.Count, 1).End(x1Up).Select
ActiveCell.PasteSpecial xlPasteValues
I get the error on the 4th row
(Application Defined or object Defined error).
Your code can be condensed using the example from https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy:
Worksheets("Sheet1").Range("A1:D4").Copy destination:=Worksheets("Sheet2").Range("E5")
Applied to your work:
Dim lRow As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Sourcews As Worksheet: Set Sourcews = wb.Worksheets("Sheet21")
Dim Destinationws As Worksheet: Set Destinationws = wb.Worksheets("Sheet1")
lRow = Destinationws.Cells(Destinationws.Rows.Count, "A").End(xlUp).Row + 1
Sourcews.Range("A1:D4").Copy Destination:=Destinationws.Range("A" & lRow)
Avoid using activate and select. It is slow and can be unreliable.
Try this code, please. It will copy the selected range values in the last empty row of column A:A. I deduced that from your way of trying to calculate. But, you did that in an incorrect way. You would copy your range over the "A1:A" & last cell range. Is that what you really want?
Sub testCopyValues()
Dim sh As Worksheet, lastRow As Long, rng As Range
Set rng = Selection
Set sh = Workbooks("Workbook1").Sheets(1)
lastRow = sh.Cells(Rows.count, 1).End(xlUp).row
sh.Range("A" & lastRow + 1).Resize(rng.Rows.count, rng.Columns.count).Value = rng.Value
End Sub
If you need to paste on another sheet of the same workbook, please replace
Set sh = Workbooks("Workbook1").Sheets(1) with Set sh = ActiveWorkbook.Sheets(1)
I have two Excel files.
I am trying to do the following:
Search for a value in Sheet one.
When item is found use offset to pick up the adjacent value i.e. 4 columns to the left (same row)
Add the value (in step 2) to sheet two at the end of Row D
Struggling with the third step.
I get method or data member not found.
Sub findOne()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("one") ' ref to sheet one
Set ws2 = ThisWorkbook.Sheets("two") ' ref to sheet two
Dim rng As Range
With ws1
' use find on range H
Set rng = Range("H1:H200").Find(What:="busaoc", LookAt:=xlPart)
'- doesn't like this
ws2.Range("D2").End(xlDown).Offset(1, 0) = ws1.rng(.Offset(0, -4))
End With
end Sub
You were not using your With block, but I removed it here since it doesn't seem necessary if this is your complete code. This has also been amended to not crash on the chance your value is actually not found.
Sub findOne()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("one")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("two")
Dim rng As Range, LR As Long
Set rng = ws1.Range("H1:H200").Find(What:="busaoc", LookAt:=xlPart)
If rng Is Nothing Then
MsgBox "Value not found"
Else
LR = ws2.Range("D" & ws2.Rows.Count).End(xlUp).Offset(1).Row
ws2.Range("D" & LR).Value = rng.Offset(0, -4).Value
End If
End Sub
New to VBA and trying to write a macro that will copy a reference number (column A) of an entry if column Y contains certain text (CHK). I have been able to set up an array that will check if a cell contains the value CHK and copies the reference number if it does (with this then repeating for each cell).
What i am struggling with is pasting the values for each cell into the next empty cell in row A of another workbook. I have managed to copy the value into the next empty cell but I am unsure how to then move one cell down for the next run through of the array. Whereas, at the moment the value in the cell is overridden each time the array runs
My current code is shown below:
Sub Copy_detailed_WithNum_V2()
Application.ScreenUpdating = True
Dim ws1 As Worksheet, ws2 As Worksheet
Dim SrchRng As Range, cel As Range
Set ws1 = Sheets("Detailed Register-All")
Set ws2 = Sheets("VIPP Register")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Activate Detailed Reigster sheet
ws1.Activate
Set SrchRng = Range("Y:Y")
For Each cel In SrchRng
'Check if the cell contains CHK text
If InStr(1, cel.Text, "CHK") Then
'Copy rerference number if entry has CHK value
cel.Offset(0, -24).Copy
'Activate VIPP Register sheet
ws2.Activate
'Paste in the next empty cell in Coulmn A
Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
End If
'Check next cell
Next cel
End Sub
The issue is likely due to your instances of Range and Cells not being qualified with a worksheet. Also, notice that you do not need to Activate a worksheet in order to modify it.
Instead of copying values, you can just set the value of 2 ranges equal to each other which is what I have done here.
Laslty, your search range is currently set to Y:Y which is the entire column (a little over 1 million cells to check). You need to minimize this to a minimal/necessary range. I have this set to start in Y2 (assuming you have a header) and scan down to the last used cell in column Y
Sub Copy_detailed_WithNum_V2()
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim SrchRng As Range, cel As Range, lastRow As Long
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each cel In SrchRng
If InStr(1, cel.Text, "CHK") Then
lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
ws2.Cells(lastRow, 1).Value = cel.Offset(0, -24).Value
End If
Next cel
Application.ScreenUpdating = True
End Sub
Would like to create a Macro to loop through all of the sheets in the workbook and select all the data from each worksheet and then paste said data into a single consolidate table on the "Master" sheet. All sheets have the same column heading to Column "AB".
Currently tried using this code but I have been unable to get anything to paste over onto the Master worksheet. Might be overthinking setting the range each tab.
Just looking for a simple solution to copy all active data from each sheet and paste it into one sheet so that is its all consolidated.
Thanks in advance!
Sub CombineData()
Dim wkstDst As Worksheet
Dim wkstSrc As Worksheet
Dim WB As Workbook
Dim rngDst As Range
Dim rngSrc As Range
Dim DstLastRow As Long
Dim SrcLastRow As Long
'Refrences
Set wkstDst = ActiveWorkbook.Worksheets("Master")
'Setting Destination Range
Set rngDst = wkstDst.Cells(DstLastRow + 1, 1)
'Loop through all sheets exclude Master
For Each wkstSrc In ThisWorkbook.Worksheets
If wkstSrc.Name <> "Master" Then
SrcLastRow = LastOccupiedRowNum(wkstSrc)
With wkstSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(SrcLastRow, 28))
rngSrc.Copy Destination:=rngDst
End With
DstLastRow = LastOccupiedRowNum(wkstDst)
Set rngDst = wkstDst.Cells(DstLastRow + 1, 1)
End If
Next wkstSrc
End Sub
Throwing another method into the mix. This does assume that the data you are copying has as many rows in column A as it does in any other column. It doesn't require your function.
Sub CombineData()
Dim wkstDst As Worksheet
Dim wkstSrc As Worksheet
Dim rngSrc As Range
Set wkstDst = ThisWorkbook.Worksheets("Master")
For Each wkstSrc In ThisWorkbook.Worksheets
If wkstSrc.Name <> "Master" Then
With wkstSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 28)
rngSrc.Copy Destination:=wkstDst.Cells(Rows.Count, 1).End(xlUp)(2)
End With
End If
Next wkstSrc
End Sub
You have copied this from somewhere else and you have forgotten to copy the function that gets the last row of a worksheet, namely this one LastOccupiedRowNum
So add this function to the same module and the code should work. Please don't forget to mark this as the right answer if it did work:
Function LastOccupiedRowNum(Optional sh As Worksheet, Optional colNumber As Long = 1) As Long
'Finds the last row in a particular column which has a value in it
If sh Is Nothing Then
Set sh = ActiveSheet
End If
LastOccupiedRowNum= sh.Cells(sh.Rows.Count, colNumber).End(xlUp).row
End Function
Try finding the last row dynamically, rather than using .cells
Dim lrSrc as Long, lrDst as Long, i as Long
For i = 1 to Sheets.Count
If Not Sheets(i).Name = "Destination" Then
lrSrc = Sheets(i).Cells( Sheets(i).Rows.Count,"A").End(xlUp).Row
lrDst = Sheets("Destination").Cells( Sheets("Destination").Rows.Count, "A").End(xlUp).Row
With Sheets(i)
.Range(.Cells(2,"A"), .Cells(lrSrc,"AB")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst+1,"A"),Sheets("Destination").Cells(lrDst+1+lrSrc,"AB"))
End With
End If
Next i
This should replace your sub and the related function.
I'm trying to copy a range of cells from one data file (sh1 as Worksheet) to another (sho as Worksheet). The cells should be pasted beneath the existing data. Since the amount of cells to copy and the amount of existing data varies. I created this code:
Dim sh1 As Worksheet, sho As Worksheet, lr As Long, rng1 As Range
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng1 = sh1.Range("A3:B" & lr)
rng1.Copy sho.Cells(Rows.Count, 1).End(xlUp)(2)
This works perfectly fine - but it copies the functions in the Worksheet sh1 to the Worksheet sho and not the values. I know that the code for this is ".PasteSpecial" but I'm not able to match it in my code, without destroying the other prerequisites.
If you have Sheet1 and Sheet2 please try the below:
Option Explicit
Sub test()
Dim sh1 As Worksheet, sho As Worksheet, lr As Long, rng1 As Range
Set sh1 = Sheet1
Set sho = Sheet2
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng1 = sh1.Range("A3:B" & lr)
rng1.Copy
sho.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
End Sub
Instead of:
rng1.Copy sho.Cells(Rows.Count, 1).End(xlUp)(2)
Assign the values directly. It avoids the clipbaord and thus it is quicker:
sho.Cells(sho.Rows.Count, 1).End(xlUp).Offset(2).Resize(rng1.rows,rng1.columns).Value = rng1.Value
You can use this code to copy the value of A1 to B1 (if A1 is a formula)
Range("B1").Formula = Range("A1")