I would like to copy data from sheet INV_LEDGERSinto Ready to uploadsheet, but the sheet Ready to upload already contains some data and therefore I want to loop through the column A in Ready to upload sheet until it will find the blank cell and then paste the data from INV_LEDGERS.
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If ws.Range("A" & i) > "" And ws1.Range("A" & i + 1) = "" Then
ws.Range("A" & i & ":AE" & i).Copy
ws1.Range("A" & i + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else
End If
Next
End Sub
It doesnt show the error msg anymore, but now it copies the data from INV_LEDGERSfrom the row, where data on sheet Ready to upload ends. I mean, that if data on Ready to upload has the end on row 82, the code will take the data from INV_LEDGERS from 82. row, so basically there are missing 81 rows.
Could you advise me, please?
Thanks a lot!
Given the comments from braX, here is my code.
Since you are always starting on the 4th row of the ledger data, you can just copy the entire section and then paste it to your last row + 1 on your upload sheet.
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRow, LRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A4:AE" & LastRow).Copy
ws1.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End Sub
Couple things... have used a With statement, and instead of copy/paste, I'm just making ws1.Value=ws.Value:
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet, LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
With ws
LastRow = .Cells( .Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If .Range("A" & i) > "" And ws1.Range("A" & i + 1) = "" Then
ws1.Range("A" & i + 1 & ":AE" & i + 1).Value = .Range("A" & i & ":AE" & i).Value
End If
Next
End With
End Sub
Edit
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet, LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
With ws
LastRow = .Cells( .Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If IsEmpty(ws1.Range("A" & i + 1)) Then
ws1.Range("A" & i + 1 & ":AE" & i + 1).Value = .Range("A" & i & ":AE" & i).Value
End If
Next
End With
End Sub
Related
Trying to copy account numbers and instances of a transaction from 2 columns (Columns "C" and "D", beginning at row 13) in a selected workbook to my workbook, but only if the value in Column D is greater than 1. Also, the last row in the column is labeled "Grand Total", so obviously I want to not included that row.
So far, this is what I have:
Private Sub CmdGetData_Click()
Dim wb As Workbook, wb2 As Workbook
Dim NewFile As Variant
Dim ws As Worksheet, ws2 As Worksheet
NewFile = Application.GetOpenFilename("Excel-files (*.xlsx*, *.xlsx*")
If NewFile <> False Then
Set wb = ThisWorkbook
Set wb2 = Workbooks.Open(NewFile)
End If
Set ws = Worksheets("Main")
Set ws2 = wb2.Worksheets("IVR Late Fee Clean Up")
lastrow1 = ws.Cells(Rows.Count, 2).End(xlUp).Row
For i = 13 To lastrow2
lastrow2 = wb2.ws2.Cells(Rows.Count, 3).End(xlUp).Row
If wb2.ws2.Range("C" & i).Value = "Grand Total" Then GoTo Skip
If wb2.ws2.Range("D" & i).Value = "2" Then
wb.ws.Range("B" & lastrow1 + 1).Value = wb2.ws2.Range("C" & i)
wb.ws.Range("C" & lastrow1 + 1).Value = wb2.ws2.Range("D" & i)
End If
Next i
Skip:
End Sub
The problem I am getting is "Run-time error '9': Subscript out of range".
Please help!
1.
If wb2.ws2.Range("C" & i).Value = "Grand Total" Then GoTo Skip
needs to be:
If ws2.Range("C" & i).Value = "Grand Total" Then GoTo Skip
2. Also,
wb.ws.Range("B" & lastrow1 + 1).Value = wb2.ws2.Range("C" & i)
needs to be:
ws.Range("B" & lastrow1 + 1).Value = ws2.Range("C" & i)
etc...
3. And, one last thing, you have a For loop:
For i = 13 To lastrow2
But, you never set a value for lastrow2 up to this point, only at the following line you have:
lastrow2 = wb2.ws2.Cells(Rows.Count, 3).End(xlUp).Row
So you need to move that up 2 lines of code.
Modified Code
Option Explicit
Private Sub CmdGetData_Click()
Dim wb As Workbook, wb2 As Workbook
Dim NewFile As Variant
Dim ws As Worksheet, ws2 As Worksheet
Dim lastrow1 As Long, lastrow2 As Long, i As Long
NewFile = Application.GetOpenFilename("Excel-files (*.xlsx*, *.xlsx*")
If NewFile <> False Then
Set wb = ThisWorkbook
Set wb2 = Workbooks.Open(NewFile)
'====== ALL this code below needs to be inside the If NewFile <> False Then part =====
Set ws = wb.Worksheets("Main")
Set ws2 = wb2.Worksheets("IVR Late Fee Clean Up")
lastrow1 = ws.Cells(Rows.Count, 2).End(xlUp).Row
lastrow2 = ws2.Cells(Rows.Count, 3).End(xlUp).Row
For i = 13 To lastrow2
If ws2.Range("C" & i).Value = "Grand Total" Then Exit For
If ws2.Range("D" & i).Value = "2" Then
ws.Range("B" & lastrow1 + 1).Value = ws2.Range("C" & i).Value
ws.Range("C" & lastrow1 + 1).Value = ws2.Range("D" & i).Value
End If
Next i
End If
End Sub
Thank you all for your input. The code below worked! (Thank you #ShaiRado)
Private Sub CmdGetData_Click()
Dim wb As Workbook, wb2 As Workbook
Dim NewFile As Variant
Dim ws As Worksheet, ws2 As Worksheet
NewFile = Application.GetOpenFilename("Excel-files (*.xlsx*, *.xlsx*")
If NewFile <> False Then
Set wb = ThisWorkbook
Set wb2 = Workbooks.Open(NewFile)
End If
Set ws = wb.Sheets("Main")
Set ws2 = wb2.Sheets("IVR Late Fee Clean Up")
lastrow1 = ws.Cells(Rows.Count, 2).End(xlUp).Row
lastrow2 = ws2.Cells(Rows.Count, 3).End(xlUp).Row
For i = 13 To lastrow2
If ws2.Range("C" & i).Value = "Grand Total" Then GoTo Skip
If ws2.Range("D" & i).Value = "2" Then
ws.Range("B" & lastrow1 + 1).Value = ws2.Range("C" & i)
ws.Range("C" & lastrow1 + 1).Value = ws2.Range("D" & i)
End If
Next i
Skip:
End Sub
And #Ryszard: I didn't get the debug option because I was running from the script editor, not the actual command button. My mistake.
I want to copy certain cells (for, if then condition) to an other sheet. I got great help with my code and it smoothly runs through the lines so far, but still it doesn't do exactly what I want.
I want to look for the value 848 in column A, if there is 848 in a certain row X, I want to copy the content of the following cells: XA, XN, XO, XAM, AH, XP XE and XF to the other worksheet. But: the columns do not remain the same. They change from one to the other workbook like:
Copy value in the column X in “source” --> Column Y in “target”
A --> A, N-->B, O-->C, AM -->D, AH -->G, P-->I, E-->J, F-->K
After checking and copy pasting all the needed cells of rows containing 848 in column A, we do the same for the rows containing 618 in column A.
A --> A N-->B O-->C AM -->D T -->G P-->I E-->J F-->K
As I said, the code in general works properly, it's just that I don't get the right values to the cell I want them to. Any ideas? Thanks a lot!
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("invoices_eCMS.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Data exAlps")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
.Range(.Cells(i, 1), .Cells(i, 14)).Copy
'.Cells(i, 1).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
z = z + 1
', .Cells(i, 14)).Copy
End If
Next i
Next j
End With
End Sub
Updated Code:
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("invoices_eCMS.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Data exAlps")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
wsDest.Range("A" & z).Value = .Range("A" & i).Value
wsDest.Range("B" & z).Value = .Range("N" & i).Value
wsDest.Range("C" & z).Value = .Range("O" & i).Value
wsDest.Range("D" & z).Value = .Range("AM" & i).Value
wsDest.Range("G" & z).Value = .Range("AH" & i).Value
wsDest.Range("I" & i).Value = .Range("P" & z).Value
wsDest.Range("J" & i).Value = .Range("E" & z).Value
wsDest.Range("K" & i).Value = .Range("F" & z).Value
z = z + 1
', .Cells(i, 14)).Copy
End If
Next i
Next j
End With
End Sub
The problem exists here:
.Range(.Cells(i, 1), .Cells(i, 14)).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
where are you defining a specific range to copy and specific place to paste.
Since you want to copy certain columns in one sheet to different columns in your other sheet, you'll need to specify each one separately. See my example below. I didn't do each iteration, but you can just copy the code I wrote and adjust for each:
wsDest.Range("A" & z).Value = .Range("A" & i).Value
wsDest.Range("B" & z).Value = .Range("N" & i).Value
wsDest.Range("C" & z).Value = .Range("O" & i).Value
'... and so on for each cell that needs to be copied
If it's not clear, replace the code where I stated the problem was with the code I provided as a solution.
I am new to VBA and found what I thought was the answer to my question but is not working. If on my Sheet1 column F contains the value "A - 6:30PM" then I would like the entire row to be copied to a second sheet.
This was the code I was previously using. What is going wrong?
Sub Test()
For Each Cell In Sheets(1).Range("F:F")
If Cell.Value = "A - 6:30PM" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("A").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("A").Select
End If
Next
End Sub
Try changing Sheets("A").Select with Sheets(1).Select at the very end of your code.
This is a cleaner way to do it.
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
Dim lRow as Long
'Starting at row 1 loop through each row of the used range.
lRow = 1
Do While lRow <= ws.UsedRange.Rows.Count
If ws.Range("F" & lRow).Value = "A - 6:30PM" then
Rows(lRow & ":" & lRow).Select
Selection.Copy
Sheets("A").Select
ActiveSheet.Rows(lRow).Select
ActiveSheet.Paste
Sheets("A").Select
End If
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
I'm not sure how your paste code knows what row to paste each row to. But if you need to keep track of a row to paste to just add another counter for the second sheet.
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
'Starting at row 1 loop through each row of the used range.
Dim lRow as Long
Dim lTargetRow as Long
lTargetRow = 1
lRow = 1
Do While lRow <= ws.UsedRange.Rows.Count
If ws.Range("F" & lRow).Value = "A - 6:30PM" then
Rows(lRow & ":" & lRow).Select
Selection.Copy
Sheets("A").Select
ActiveSheet.Rows(lRow).Select
ActiveSheet.Paste
Sheets("A").Select
lTargetRow = lTargetRow + 1
End If
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
I currently have a script (See Below) that adds the contents of every cell in the used rows to another cell in a different worksheet. However, this works for the first 3 cells but will not work for the last 2 for some reason.
Sub Ready_For_Infra()
Dim i As Integer
Dim k As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row Step 1
For k = 1 To ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
With Worksheets("InfraData")
If ws2.Cells(k, i).Value <> "" Then
ws1.Range("A" & i).Value = ws1.Range("A" & i).Value & ws2.Cells(i, k).Value & Chr(10)
End If
End With
Next k
Next i
MsgBox "Done"
End Sub
This is the data in ws2 (ActionPlan) just in case it helps:
To clarify, it doesn't appear to be appending Cells D2:F3 to the cells I have asked it to. Is anyone able to advise why this might be the case?
Try this code:
Sub Ready_For_Infra()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range
Dim i As Long, lastrow As Long, lastcol As Long
Dim str1 As String
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
With ws2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To lastrow
str1 = ""
For Each cell In .Range(.Cells(i, 1), .Cells(i, lastcol))
If cell.Value <> "" Then str1 = str1 & cell.Value & Chr(10)
Next cell
ws1.Range("A" & i).Value = str1
Next i
End With
MsgBox "Done"
End Sub
Notes:
using For each loop is slightly faster then For k=1 To lastcol
using temporary string variable str1 makes your code faster as well, because in that case you writes result value in ws1.Range("A" & i) cell only once (working with operating memory is always faster than writing subresult in cell for each iteration).
I have this script that I had help with already, but now comes an issue. I am attempting to paste only the value, not the formula that is inside the cell to another cell.
I thought placing the .Value at the end of formula would tell the script to paste only the value... it seems not to be. Can someone give me a suggestion on how to make this work?
Option Explicit
Sub ONJL()
Dim lastrow As Long
Dim wsPAR As Worksheet 'PAERTO
Dim wsRD As Worksheet 'Raw Data
Dim wsTEM As Worksheet 'Archive
Set wsPAR = Sheets("PAERTO")
Set wsRD = Sheets("Raw Data")
Set wsTEM = Sheets("Template")
With wsRD
Application.ScreenUpdating = False
lastrow = .Range("J" & .Rows.Count).End(xlUp).Row
wsRD.Range("J" & lastrow + 1).Formula = Date
wsRD.Range("B2").Copy wsRD.Range("K" & lastrow + 1).Value
wsRD.Range("B3").Copy wsRD.Range("L" & lastrow + 1).Value
wsRD.Range("E2").Copy wsRD.Range("M" & lastrow + 1).Value
wsRD.Range("E3").Copy wsRD.Range("N" & lastrow + 1).Value
wsRD.Range("H2").Copy wsRD.Range("O" & lastrow + 1).Value
wsRD.Range("H3").Copy wsRD.Range("P" & lastrow + 1).Value
wsRD.Range("Q1:T1").Copy wsRD.Range("Q" & lastrow + 1)
Application.ScreenUpdating = False
End With
End Sub
You can "copy" without actually using .Copy like this:
Sub CopyWithoutCopying()
Dim wsRD As Worksheet
Dim lastrow As Long
Set wsRD = Sheets("Raw Data")
With wsRD
lastrow = .Range("J" & .Rows.Count).End(xlUp).Row
.Range("K" & lastrow + 1).Value = .Range("B2").Value
.Range("L" & lastrow + 1).Value = .Range("B3").Value
' etc...
End With
End Sub
This approach doesn't use your clipboard, performs better, and doesn't select anything. And as Jimmy points out, you don't need the wsRD prefix inside the With block.