I have problem to make a dynamic range to copy between two workbooks. I have create the following code and when I run step by step the code I take “Run time error 1004” “Method Range of object worksheet failed” My thought is to create dynamic range for the workbook with new data because is change all the time and the only last cell with data is in column “D” then expand this to column “S” and copy this to Master workbook Data sheet and again find the last used cell in column D and offset this to column “A” . How can make this task?
Sub CopyValuesToMaster()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim RngAC1 As Range
Dim RngAC2 As Range
Dim NewRng As Range
Dim DestLastRow As Long
Set wsCopy = Workbooks("sl0032019.xls").Worksheets("Sheet1")
Set wsDest = Workbooks("Master-Braun.xlsx").Worksheets("Data")
DestLastRow = Cells(Rows.Count, "D").End(xlUp).Offset(1, -3).Row
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
Set RngAC1 = wsCopy.Range("A1")
Set RngAC2 = wsCopy.Range(Cells(Rows.Count, "D").End(xlUp).Offset(0, 15).Row)
Set NewRng = Range(RngAC1.Address & ":" & RngAC2.Address)
NewRng.Copy wsDest.Range("A" & DestLastRow)
End Sub
Try this.
Sub CopyValuesToMaster()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim RngAC1 As Range
Dim RngAC2 As Range
Dim NewRng As Range
Dim DestLastRow As Long
Set wsCopy = Workbooks("sl0032019.xls").Worksheets("Sheet1")
Set wsDest = Workbooks("Master-Braun.xlsx").Worksheets("Data")
DestLastRow = wsDest.Cells(Rows.Count, "D").End(xlUp).Offset(1, -3).Row
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
With wsCopy
Set RngAC1 = .Range("A1")
Set RngAC2 = .Range("S" & .Cells(.Rows.Count, "D").End(xlUp).Row)
End With
Range(RngAC1, RngAC2).Copy wsDest.Range("A" & DestLastRow)
End Sub
Related
Dim lastrow As Long, lastrow2 As Long
Dim wksSource As Worksheet, wksDest As Worksheet
Dim source1 As Range, target1 As Range, source2 As Range, target2 As Range
Set wksSource = Workbooks("2021 Tracker.xlsm").Worksheets("Sheet3")
Set wksDest = Workbooks("Jan Tracker).xlsm").Worksheets("Sheet1")
lastrow = wksSource.Cells(Rows.Count, 1).End(xlUp).row
lastrow2 = wksDest.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).row
Set source1 = wksSource.Range("A2:A" & lastrow)
Set source2 = wksSource.Range("B2:B" & lastrow)
Set target1 = wksDest.Range("E" & lastrow2)
Set target2 = wksDest.Range("F" & lastrow2)
source1.Copy: target1.PasteSpecial Paste:=xlPasteValues
source2.Copy: target2.PasteSpecial Paste:=xlPasteValues
This code replaces data in columns E and F of destination workbook, but i want it to append to it. Please help.
Your code determines the next row in column A of the destination worksheet: lastrow2 = wksDest.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).Row. But you are pasting to columns E and F. Therefore the last row in column A doesn't change and that results in over-writing.
I have re-written your code to make it more transparent. I think this kind of syntax will make it easier for you to spot errors like the one that you asked about. It may take a little more time to set up but the time is well invested.
Sub AppendData()
Dim wksSource As Worksheet ' Source sheet
Dim wksTarget As Worksheet ' Target sheet
Dim Source1 As Range
Dim Target As Range
Dim Rl As Long ' last row
Set wksSource = Workbooks("2021 Tracker.xlsm").Worksheets("Sheet3")
With wksSource
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Source = .Range(.Cells(2, "A"), .Cells(Rl, "B"))
End With
Set wksTarget = Workbooks("Jan Tracker).xlsm").Worksheets("Sheet1")
With wksTarget
Set Target = .Cells(.Rows.Count, "E").End(xlUp).Offset(1)
End With
Source.Copy Deestination:=Target
Application.CutCopyMode = False
End Sub
I am trying to filter out anything that is below 70% to populate on a separate sheet.
Image of what I am pulling from.
I looked online and got a little code.
Here is what I have and am running into an error.
Private Sub CommandButton1_Click()
lastrow = Worksheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lastrow
If Worksheets("sheet1").Range("O" & r).Value < "70%" Then
Worksheets("sheet1").Rows(r).Copy
Worksheets("sheet2").Activate
lastrowrpt = Worksheets("sheet2").Range("O" & Row.Count).End(xlUp).Row
Worksheets("sheet2").Range("O" & lastrowrpt + 1).Select
ActiveSheet.Paste
End If
Next r
End Sub
This should get you started
In this case you can use the filter and visible cells to copy the range to the other worksheet.
Adjust it to fit your needs
Private Sub CommandButton1_Click()
Dim sourceSheet As Worksheet
Dim sourceRange As Range
Dim sourceFilteredRange As Range
Dim targetSheet As Worksheet
Dim targetCell As Range
Dim cell As Range
Dim sourceLastRow As Long
Dim targetLastRow As Long
' Define source and target objects
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set targetSheet = ThisWorkbook.Worksheets("Sheet2")
' Get last row of source sheet
sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
' Get last row of target sheet
targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
' Set source range
Set sourceRange = sourceSheet.Range("A1:O" & sourceLastRow)
' Filter source range by route and shipped
With sourceRange
.AutoFilter Field:=15, Criteria1:="<70%"
End With
' Get filtered range
Set sourceFilteredRange = sourceRange.SpecialCells(xlCellTypeVisible)
' Copy filtered range to target sheet
sourceFilteredRange.Copy targetSheet.Range("A" & targetLastRow)
End Sub
Let me know if it works
I would like my code to compare cells using an If statement. When the cells are not equal, I want to run my other code.
It is showing red on my screen when I try to do the Else If statement.
Dim WS1 As Worksheet: Set WS1 = ThisWorkbook.Sheets("Increments")
Dim WS2 As Worksheet: Set WS2 = ThisWorkbook.Sheets("Output")
Dim LR1 As Long, LR2 As Long, WS1_Cell As Range, WS2_Cell As Range
LR1 = WS1.Range("S" & WS1.Rows.Count).End(xlUp).Row
LR2 = WS2.Range("H" & WS2.Rows.Count).End(xlUp).Row
For Each WS1_Cell In WS1.Range("S1:S" & LR1)
For Each WS2_Cell In WS2.Range("H1:H" & LR2)
Else If WS1_Cell = WS2_Cell Then
WS2_Cell.Offset(, 5).Value = WS1_Cell.Offset(, 5).Value
Next WS2_Cell
Next WS1_Cell
Else WS1_Cell <> WS2_Cell Then
Dim wsCopy2 As Worksheet
Dim wsDest2 As Worksheet
Dim lCopyLastRow2 As Long
Dim lDestLastRow2 As Long
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
'Set variables for copy and destination sheets
Set wsCopy2 = Worksheets("Increments")
Set wsDest2 = Worksheets("Output")
'1. Find last used row in the copy range based on data in column S
lCopyLastRow2 = wsCopy2.Cells(wsCopy2.Rows.Count, "S").End(xlUp).Row
'2. Find first blank row in the destination range based on data in column H
'Offset property moves down 1 row
lDestLastRow2 = wsDest2.Cells(wsDest2.Rows.Count, "H").End(xlUp).Offset(1).Row
'3. Copy & Paste Data if match not found
wsCopy2.Range("S3:X" & lCopyLastRow2).COPY
wsDest2.Range("H" & lDestLastRow2).PasteSpecial xlValues
End If
I am currently trying to make a macro to pull all of the data from a specific row on my sales quote template workbook and then make it paste into the next available row on my quote logger workbook but im really struggling to find the right code to make it work. ive searched around but found nothing concrete that I could use.
what I have so far is below.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = "..............RAYOTEC LOGGER.xlsm"
For i = 2 To sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "M").End(xlUp).Row + 1)
End If
Next i
End Sub
Thanks in advance for any help
Change the part of your code before FOR loop with this,
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wb As Workbook
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set wb = Application.Workbooks.Open("..............RAYOTEC LOGGER.xlsm")
Set sht2 = wb.Sheets("Sheet1")
Also you can use the below for the rest of the code as it just takes the values easily and deletes the row data that you do not need.
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim i, n As Long
Dim iMx, nMx As Long
iMx = sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
For i = 2 To iMx
nMx = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht2.Range("A" & nMx + 1).EntireRow.Value = sht1.Range("A" & i).EntireRow.Value
sht1.Range("A" & i).EntireRow.Delete Shift:=xlUp
i = i - 1
End If
Next i
I have two separate Excel files. In one of these in Sheet1 is stored infomration about orders and order numbers. Now every time I make a new order I want this information be collected from my order and inserted in to so called "database" workbook. It should identify the last empty row in column A:A in C:\Users\user\Desktop\Order_number.xlsx and insert new values from range ("C6,C17,C10,H18,B32,G32,H6,H9") to the next empty row. Here is the code I came up to but there is some mistake and it is not working. How it can be fixed?
Sub TransferValues465()
Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.ActiveSheet
Dim wsData As Worksheet: Set wsData = Workbooks.Open("C:\Users\user\Desktop\Order_number.xlsx").Sheets("Sheet1")
Dim rngToCopy As Range: Set rngToCopy = wsMain.Range("C6,C17,C10,H18,B32,G32,H6,H9")
Dim c As Long
Dim ar As Range
Dim cl As Range
Dim LastRow As Long
Dim rngDestination As Range
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
'Get the last row in Database sheet:
LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
Set rngDestination = wsData.Cells(LastRow + 1, 1).Resize(1, 25).Offset(0, 0)
For Each ar In rngToCopy.Areas
For Each cl In ar
c = c + 1
'I used this next line for testing:
' rngDestination.Cells(c).Value = cl.Address
rngDestination.Cells(c).Value = cl.Value
Next
Next
End Sub
A few corrections:
1) Set wsData = Workbooks("C:\Users\user\Desktop\Order_number.xlsx").Sheets("Sheet1") will not work. Either use Set wsData = Workbooks("Order_number.xlsx").Sheets("Sheet1") if the workbook is open. Or you need to open the workbook first.
2) I am not famliar on using Application.WorksheetFunction.CountA(wsData.Range("A:A")) to get the last row. To get the last row in Column A (with the possibility of skipping balnk cells in the middle) use wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row.
3) My preference is to use Copy >> PasteSpecial xlPasteValues with cl.Copy and the following line wsData.Range("A" & C).PasteSpecial xlPasteValues.
Code
Option Explicit
Sub TransferValues465()
Dim wsMain As Worksheet
Dim wbData As Workbook
Dim wsData As Worksheet
Dim rngToCopy As Range
Dim C As Long
Dim ar As Range
Dim cl As Range
Dim LastRow As Long
Dim rngDestination As Range
Set wsMain = ThisWorkbook.ActiveSheet
Application.DisplayAlerts = False
' you need to open the workbook
Set wbData = Workbooks.Open("C:\Users\user\Desktop\Order_number.xlsx")
Set wsData = wbData.Sheets("Sheet1")
Set rngToCopy = wsMain.Range("C6,C17,C10,H18,B32,G32,H6,H9")
'Get the last row in Database sheet:
LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
C = 1
For Each cl In rngToCopy
cl.Copy
wsData.Cells(LastRow + 1, C).PasteSpecial xlPasteValues
C = C + 1
Next cl
wbData.Close True '<-- close and save the changes made
Application.DisplayAlerts = True '<-- restore settings
End Sub