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:
Related
I'm new to this forum. and I have some problem.
I want to copy a list from sheet "Import Data" to sheet "June" but each list I want to skip few rows.
I've come out with some code but it didn't work. When I run the code individually, it skips the second For loop.
please help me.
Sub copypasteskip()
Dim sheet1 As Variant
Dim sheet2 As Variant
Dim endnumber As Integer
Dim finalrow As Variant
Dim i As Integer
Dim r As Integer
Set sheet1 = ThisWorkbook.Worksheets("June")
Set sheet2 = ThisWorkbook.Worksheets("ImportData")
endnumber = sheet1.Cells(Rows.Count, "A").End(xlUp).Row
finalrow = sheet2.Cells(Rows.Count, "D").End(xlUp).Row
For r = 11 To endnumber 'the list should paste starts at rows 11, cells "A"
For i = 14 To finalrow 'the list need to be copy starts at rows 14,cells "D"
sheet2.Cells(i, "D").End(xlDown).Copy
sheet1.Cells(r, "A").PasteSpecial xlPasteValues
Next i
r = r + 7 'need to skips 7 rows for each list
Next r
End sub
If your second For loop doesn’t run that means that the value of finalrow is less than 11. Try using the locals Windows or hovering your mouse over the name to see its value. You could also insert a debug.print(finalrow)
just before the first loop.
Sub copypasteskip()
Dim sheet1 As Variant
Dim sheet2 As Variant
Dim endnumber As Integer
Dim finalrow As Variant
Dim i As Integer
Dim r As Integer
Set sheet1 = ThisWorkbook.Worksheets("June")
Set sheet2 = ThisWorkbook.Worksheets("ImportData")
endnumber = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
finalrow = sheet2.Cells(Rows.Count, 4).End(xlUp).Row
For r = 11 To endnumber Step 7 'the list should paste starts at rows 11, column 1
For i = 14 To finalrow 'the list need to be copy starts at rows 14,column 4
sheet1.Cells(r, 1) = sheet2.Cells(i, 4)
Next i
Next r
End sub
I have a bunch of non-contiguous data in a table across 108 rows and 15 columns. I'm trying to find the last used cell in every row and paste it to another worksheet.
For example: row 3 last data on column J, row 5 column O...row 38 column I, and so on
I am very new to writing VBA, any help would be great
EDITED
This is what i have:
Sub Selectionoflastcell()
Dim lRow As Long
Dim lCol As Long
Dim ccol As Range
Dim i As Long
With Worksheets("May-July Quarter").ListObjects("Table2").DataBodyRange
Worksheets("Sheet1").Cells(1, 2).ClearContents
lCol = .Cells(1, .Columns.Count).End(xlToRight).Column
Set colrange = .Range(.Cells(1, 1), .Cells(1, lCol))
i = 1
For Each ccol In colrange
lRow = .Cells(.Rows.Count, ccol.Column).End(xlUp).Row
Worksheets("Sheet1").Cells(i, 2).Value = .Cells(lRow, ccol.Column).Value
i = i + 1
Next ccol
End With
End Sub
But it is just giving me the last value of each column from the bottom, if I change it to xltoLeft, I get only the first row
Try this:
Sub Selectionoflastcell()
Dim i As Long, ws As Worksheet, rw As Range
Set ws = Worksheets("May-July Quarter")
i = 1
'loop over the table's rows
For Each rw in ws.ListObjects("Table2").DataBodyRange.Rows
Worksheets("Sheet1").Cells(i, 2).Value = _
ws.Cells(rw.Row, Columns.Count).End(xlToLeft).Value
i = i + 1
Next ccol
End Sub
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
I'm working with two sheets. One sheet has the full raw data while the other has a select few headers from sheet 1. If it finds a match on the header, i need it to copy the full column from sheet one to sheet 2
and it copies it to sheet 2
Here is my code so far but i can't figure out how to break the loop so that it goes through every column on sheet 1 until it finds a match:
Private Sub CommandButton1_Click()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range`enter code here`
Dim headerOne As Range, headerTwo As Range
Set ShtOne = Sheets("Sheet1")
Set ShtTwo = Sheets("Sheet2")
'row count
Dim b As Long
b = ShtOne.Cells(Rows.Count, 1).End(xlUp).Row
'column count in sheet 1
Dim a As Long
a = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
'column count in sheet 2
Dim c As Long
c = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Dim lastCol As Long
'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
'stops the visual flickering of files opening and closing - run at the background
Application.ScreenUpdating = False
'start loop from first row to last row
'For i = 1 To a
i = 1
j = 0
'actually loop through and find values
For Each headerOne In shtOneHead
j = j + 1
For Each headerTwo In shtTwoHead
'copy and paste each value
If headerTwo.Value = headerOne.Value Then
'copies one row at a time (a bit slow)
' headerOne.Offset(i, 0).Copy
' headerTwo.Offset(i, 0).PasteSpecial xlPasteAll
'copies whole rows at a time
ShtOne.Columns(i).Copy ShtTwo.Columns(j)
i = i + 1
Application.CutCopyMode = False
Exit For
End If
Next headerTwo
Next headerOne
'Next
End Sub
Assuming your headers are on row 1 for both sheets and that you will always be pasting on the second row on Sheet2.
Only loop through your column headers on the second sheet. Use Range.Find to search for each header on Sheet1. If the header is found, copy and paste accordingly
Sub Headerz()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim LC As Long, i As Long, LR As Long
Dim Found As Range
LC = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
For i = 1 To LC
Set Found = ws1.Rows(1).Find(ws2.Cells(1, i).Value)
If Not Found Is Nothing Then
LR = ws1.Cells(ws1.Rows.Count, Found.Column).End(xlUp).Row
ws1.Range(ws1.Cells(2, Found.Column), ws1.Cells(LR, Found.Column)).Copy
ws2.Cells(2, i).PasteSpecial xlPasteValues
End If
Set Found = Nothing
Next i
End Sub
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