This is the code I have below, it works just not sure why when it copies over into the second and third column it moves down a row.
Dim shB As Worksheet, shPM As Worksheet, lastRowB As Long, lastRowPM As Long
Dim shC As Worksheet, shD As Worksheet
Dim i As Long, lastCol As Long
Dim eRow As Long
Set shB = Worksheets("Billable")
Set shPM = Worksheets("PM_Forecast")
lastRowB = Worksheets("Billable").Cells(Rows.Count, 1).End(xlUp).Row
''Loop will run from row 6 to the last row (Row 6 is the first row in table)
For i = 6 To lastRowB
''Check Billable requests first
If shB.Cells(i, 15).Value = "Detailed Estimate Submitted" Then
''Copy over ID reference
shB.Cells(i, 2).Copy
eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
shB.Paste Destination:=shPM.Cells(eRow + 1, 1)
''Copy over title
shB.Cells(i, 3).Copy
eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
shB.Paste Destination:=shPM.Cells(eRow + 1, 2)
''Copy over Effort
shB.Cells(i, 9).Copy
eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
shB.Paste Destination:=shPM.Cells(eRow + 1, 3)
End If
Next
This is a pic of the results, perhaps someone can tell me where I went wrong.
Do not calculate eRow each time (based on A:A column) when try pasting to the next columns.
Use shB.Paste Destination:=shPM.Cells(eRow , 2) (not eRow + 1) for each iteration.
Otherwise, the new added value in column A:A will add another row to eRow...
Or calculate the last row for each column:
eRow = shPM.Cells(Rows.Count, 2).End(xlUp).Row and eRow = shPM.Cells(Rows.Count, 3).End(xlUp).Row, according to the column where you intend to copy the value.
You can simplify your code using Union and placing the next empty cell variable inside the If Statement so it gets recalculate each loop.
'Define your sheet variables. `ThisWorkbook` means, the workbook in which the excel code is in.
Dim wsSrce As Worksheet: Set wsSrce = ThisWorkbook.Sheets("Billable")
Dim wsDest As Worksheet: Set wsDest = ThisWorkbook.Sheets("PM_Forecast")
'Define the last row variable in the source sheet
Dim lRowSrce As Long: lRowSrce = wsSrce.Cells(Rows.Count, 1).End(xlUp).Row
With wsSrce
For i = 6 To lRowSrce
'test each row for the data in Column O.
If .Cells(i, 15).Value = "Detailed Estimate Submitted" Then
'Define the next empty row variable in the destination sheets, within your IF statement
Dim NxtEpty As Long: NxtEpty = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
'Use Union to combine the noncontinuous ranges in each row and paste to the next empty cell in the destination sheet
Union(.Cells(i, 2), .Cells(i, 3), .Cells(i, 9)).Copy Destination:=wsDest.Cells(NxtEpty, 1)
End If
Next i
End With
Related
I want to loop through a lot of data—5,734 rows to be exact. This is what I want to do for all rows:
Private Sub CommandButton1_Click()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row
Range("A2:A14").Copy Range("D2:D14")
("B2:B14").Copy Range("D15:D27")
Range("C2:C14").Copy Range("D28:D40")
Assuming that your data looks like this (colour to show more easily the groups):
The following code will paste each group (yellow, green) to the "Result" column.
Code:
Option Explicit
Sub copy_paste()
Dim lrow As Long
Dim i As Long
Dim j As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lrow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'Find the last row in column A
For i = 2 To lrow Step 13 'Loop every group (group of 13 rows) in column A
For j = 1 To 13 Step 13 'For each group, copy and paste
ws.Cells(i, "A").Resize(13).Copy ws.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) 'Copy the group and paste it to the column D. Offset by one to not overwrite the last row
ws.Cells(i, "B").Resize(13).Copy ws.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
ws.Cells(i, "C").Resize(13).Copy ws.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
Next j
Next i
End Sub
Result:
I have data in an excel file in which there is data for separated into three columns:
Date (column A), number (column B), number (column C).
This sequence gets repeated to column UI. I would like to cut the data in every three columns and paste it the last row + 1 in column a,b,c so I only have three columns of data. I am having trouble accounting for three columns of data in my code.
`Sub movedata()
Application.ScreenUpdating = False
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Cashflow Chart")
With ws
lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column 'get last column using Row 1
For i = 4 To lastcolumn 'loop though each column starting from 4
Set Rng = .Range(.Cells(1, i), .Cells(.Cells(.Rows.Count, i).End(xlUp).Row, i)) 'set range to copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(Rng.Rows.Count).Value = Rng.Value
End With
Application.ScreenUpdating = True
End Sub`
Fundimentally, change the For loop to step by 3's
Also, moving the data via a Variant Array will be faster, plus a few other things
Sub MoveData()
Application.ScreenUpdating = False
Dim i As Long
Dim Data As Variant
Dim LastColumn As Long
Dim InsertRow As Long
With ThisWorkbook.Sheets("Cashflow Chart")
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column 'get last column using Row 1
InsertRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'get insert point using column A
For i = 4 To LastColumn Step 3 'loop though each column starting from 4, step by 3
Data = .Range(.Cells(1, i + 2), .Cells(.Rows.Count, i).End(xlUp)).Value 'copy range to variant array
.Cells(InsertRow, 1).Resize(UBound(Data, 1), 3).Value = Data 'place data at end of column A data
InsertRow = InsertRow + UBound(Data, 1) 'increment insert point
Next
.Cells(1, 4).Resize(InsertRow, LastColumn - 3).ClearContents 'clear old data
End With
Application.ScreenUpdating = True
End Sub
I am trying to figure out how to set the value of a range of columns on one sheet to the value of a range of columns on another sheet. I don't want to copy the entire row I only want to target specific columns as to not potentially overwrite important information inside the other cells.
Currently my code starts at the top of Sheet 1 and loops to the bottom. With each value > 0 in column 4 it searches for the identical value in column 4 of Sheet 2. If a match is found I want to copy the values from column 10-13 on x row of Sheet 1 to column 10-13 on y row of Sheet 2.
I can make this work by matching the value in each column individually but I cannot seem to find the proper method for assigning the value for a range of columns. The first line of code is what I have that currently works. The second line is what I am attempting to copy a range of column values.
ws2.Cells(y, 4).Value = ws1.Cells(x, 4).Value
ws2.Range(y, 10:13).Value = ws1.Range(x, 10:13).Value
I have tried using the Union() method but perhaps I am not sure how to implement it in this situation. Below is the rest of my code.
Sub Upload()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1LastRow As Long, ws2LastRow As Long
Dim ws1Row As Long, ws2Row As Long
Dim FindRow2 As Range
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Sheet1")
Set wb2 = Application.Workbooks.Open("Sheet Address")
Set ws2 = wb2.Worksheets("Master")
ws1LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For ws1Row = 2 To ws1LastRow
Do While ws1.Cells(ws1Row, 4) <> ""
ws2.Range("D:D").Find(What:=ws1.Cells(ws1Row, 4).Text, _
LookIn:=xlValues).Select
r = ActiveCell.Row
ws2.Cells(r, "B").Value = ws1.Cells(ws1Row, "B").Value
ws1Row = ws1Row + 1
Loop
Next
End Sub
Range.Resize(Rows, Columns)
ws2.Range("J" & y).Resize(, 3).Value = ws1.Range("J" & x).Resize(, 3).Value
I am new to VBA. Can anyone help me on this? I have 'return/enter' separated data in cell A2 & A3 and corresponding data in column B, C & D. Is it possible to get desired result as in the image using Excel VBA?
If you want your result to be in Sheet2, then this code will do what you expect, it will check the number of Columns on Sheet1 and copy all of them into Sheet2:
Sub foo()
Dim LastRow As Long
Dim LastCol As Long
Dim ws As Worksheet: Set ws = Sheets("Sheet1") 'change this to the name of your worksheet
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'get the last row
LastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column 'get the number of columns from row 2
For i = 2 To LastRow
strTest = ws.Cells(i, 1)
Myarray = Split(strTest, Chr(10)) 'split the values on the first column into an array
For x = LBound(Myarray) To UBound(Myarray) ' loop through array
LastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row 'get the last row of Sheet2
ws2.Cells(LastRow2 + 1, 1).Value = Myarray(x) 'paste the contents into Sheet2
For y = 2 To LastCol 'loop for the number of columns on Sheet1
ws2.Cells(LastRow2 + 1, y).Value = ws.Cells(i, y) 'paste all relevant columns into Sheet2
Next y
Next x
Next i
End Sub
I review Stack Overflow almost daily to improve my VBA capabilities, when I find an interesting question, I try to construct a macro that will accomplish the task.
My code below does what I want, it loops through Sheet2, column "K" and searches for a match in Sheet1, column "A".
When a match is found, the code selects the cell in Sheet2, column "K", resizes 5 cells to the right and copies the range to a blank Sheet3, Column A.
To get each range to paste into a new row on Sheet3, I had to add an .Offset(1) on the Destination:= line.
Without the Offset the code just overwrites the data on row 1.
But, using the Offset the code starts writing the data on row 2.
My cheep fix was to just delete row 1.
I'm stuck, is there a way to fix my code, so it starts pasting the range of data on row 1?
Code is below;
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long
lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lRow1
For j = 1 To lRow2
If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
'The part below does what I want it to do, except it skips row 1.
'If I remove the "Offset.(1)" it just overwrites the data in row 1.
ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
ws3.Rows(1).Delete 'My cheep fix is to delete row 1, which is blank, to get the data to start on row 1.
End Sub
Just encase anyone want to know how I resolved my issue.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim r As Integer
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long
lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
r = 1
For i = 1 To lRow1
For j = 1 To lRow2
If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Cells(r, 1)
r = r + 1
End If
Next j
Next i