Forum Discussion
VBA code to count, copy, paste, last row, if
Try this macro:
Sub CopyData() Dim wsh1 As Worksheet Dim wsh2 As Worksheet Dim r1 As Long, r2 As Long Dim m1 As Long, m2 As Long, m3 As Long, n As Long Application.ScreenUpdating = False Set wsh1 = Worksheets("Sheet1") Set wsh2 = Worksheets("Sheet2") m1 = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row m2 = wsh1.Range("B" & wsh1.Rows.Count).End(xlUp).Row m3 = wsh1.Range("C" & wsh1.Rows.Count).End(xlUp).Row n = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).Row + 1 For r1 = 2 To m1 For r2 = 2 To m2 wsh2.Range("A" & n).Resize(m3 - 1).Value = wsh1.Range("A" & r1).Value wsh2.Range("B" & n).Resize(m3 - 1).Value = wsh1.Range("B" & r2).Value wsh2.Range("C" & n).Resize(m3 - 1, 3).Value = wsh1.Range("C2:E" & m3).Value n = n + m3 - 1 Next r2 Next r1 Application.ScreenUpdating = True End Sub
Here is a new version.
Sub CopyData()
Dim wsh1 As Worksheet
Dim wsh2 As Worksheet
Dim r1 As Long, r2 As Long
Dim m1 As Long, m2 As Long, m3 As Long, n As Long
Application.ScreenUpdating = False
Set wsh1 = Worksheets("Sheet1")
Set wsh2 = Worksheets("Sheet2")
m1 = wsh1.Range("A19").End(xlUp).Row
m2 = wsh1.Range("B19").End(xlUp).Row
m3 = wsh1.Range("C19").End(xlUp).Row - 7
n = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).Row + 1
For r1 = 8 To m1
For r2 = 8 To m2
wsh2.Range("A" & n).Resize(m3).Value = wsh1.Range("A" & r1).Value
wsh2.Range("B" & n).Resize(m3).Value = wsh1.Range("B" & r2).Value
wsh2.Range("C" & n).Resize(m3, 3).Value = wsh1.Range("C8:E" & m3 + 7).Value
With wsh2.Range("F" & n).Resize(m3)
.Formula = "=Sheet1!F8/IF(Sheet1!G8=""g"",1000,1)"
.Value = .Value
End With
wsh2.Range("G" & n).Resize(m3, 2).Value = wsh1.Range("A2:B2").Value
wsh2.Range("I" & n).Resize(m3, 2).Value = wsh1.Range("A4:B4").Value
n = n + m3
Next r2
Next r1
Application.ScreenUpdating = True
End Sub
Good Afternoon Hans
Thank you very much for all the help. The previous codes all did exactly what I asked. I did however simplify the question (for privacy reasons) with the hope of modifying it to the model where I need it, but I am stuck. I am attaching another workbook with the exact layout that I am working on. Would you please help me again?
Set wsh1 = Worksheets("Spray instruction PL")
Set wsh2 = Worksheets("Records.")
- Count the amount of cells used in wsh1 F16:F25
- Copy the counted (in step 1) amount of cells in wsh 1 and paste in in last row +1 wsh2:
Copy wsh1 column: | Paste wsh2 column: |
F | D |
G | E |
H | F |
"='Spray instruction PL'!L16*IF(OR('Spray instruction PL'!N16=""KG"",'Spray instruction PL'!N16=""L""),1000,1)/10" | G |
O | I |
R | L |
T | O |
U | A |
- Also copy and paste the value of the following cells in wsh2
Copy wsh1 cells: | Paste wsh2 column: |
$M$11 | M |
"=TEXTJOIN("" ,"",TRUE,K8,K7,K6)" | N |
"=TEXTJOIN("" ,"",TRUE,G8,G7,G6)" | Q |
$F$5 | V |
$O$8 | X |
$P$8 | Y |
- The data in step 2 and 3 should be repeated for every used cell found in wsh1 B16:B25
Columns in wsh1 with cells that needs to repeat with every counted row: | Paste wsh2 column: |
B16:B25 | B |
C16:C25 | C |
D16:D25 | W |
E16:E25 | U |
I look forward to your answer.
Kind regards
Hi Kettie,
I think this will do it, but please test thoroughly:
Sub CopyToRecords() Dim wsh1 As Worksheet Dim wsh2 As Worksheet Dim r1 As Long, r2 As Long Dim m1 As Long, m2 As Long, n As Long Application.ScreenUpdating = False Set wsh1 = Worksheets("Spray instruction PL") Set wsh2 = Worksheets("Records.") m1 = wsh1.Range("B26").End(xlUp).Row m2 = wsh1.Range("F26").End(xlUp).Row - 15 n = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).Row + 1 For r1 = 16 To m1 For r2 = 16 To m2 + 15 ' Based on column B wsh2.Range("B" & n).Resize(m2).Value = wsh1.Range("B" & r1).Value wsh2.Range("C" & n).Resize(m2).Value = wsh1.Range("C" & r1).Value wsh2.Range("W" & n).Resize(m2).Value = wsh1.Range("D" & r1).Value wsh2.Range("U" & n).Resize(m2).Value = wsh1.Range("E" & r1).Value ' Based on coluumn F wsh2.Range("D" & n).Resize(m2).Value = wsh1.Range("F" & r2).Value wsh2.Range("E" & n).Resize(m2).Value = wsh1.Range("G" & r2).Value wsh2.Range("F" & n).Resize(m2).Value = wsh1.Range("H" & r2).Value With wsh2.Range("G" & n).Resize(m2) .Formula = "='Spray instruction PL'!L16*" & _ "IF(OR('Spray instruction PL'!N16={""KG"",""L""}),1000,1)" .Value = .Value End With wsh2.Range("I" & n).Resize(m2).Value = wsh1.Range("O" & r2).Value wsh2.Range("L" & n).Resize(m2).Value = wsh1.Range("R" & r2).Value wsh2.Range("O" & n).Resize(m2).Value = wsh1.Range("T" & r2).Value wsh2.Range("A" & n).Resize(m2).Value = wsh1.Range("U" & r2).Value ' Based on fixed cells wsh2.Range("M" & n).Resize(m2).Value = wsh1.Range("M11").Value With wsh2.Range("N" & n).Resize(m2) .Formula = "=TEXTJOIN("","",TRUE,'Spray instruction PL'!$K$8," & _ "'Spray instruction PL'!$K$7,'Spray instruction PL'!$K$6)" .Value = .Value End With With wsh2.Range("Q" & n).Resize(m2) .Formula = "=TEXTJOIN("","",TRUE,'Spray instruction PL'!$G$8," & _ "'Spray instruction PL'!$G$7,'Spray instruction PL'!$G$6)" .Value = .Value End With wsh2.Range("V" & n).Resize(m2).Value = wsh1.Range("F5").Value wsh2.Range("X" & n).Resize(m2).Value = wsh1.Range("O8").Value wsh2.Range("Y" & n).Resize(m2).Value = wsh1.Range("P8").Value n = n + m2 Next r2 Next r1 Application.ScreenUpdating = True End SubGood afternoon HansVogelaar
Thank you for the swift response. It is almost there.
There is one thing that you can change for me please. I attached the doc. after I ran the code. There is three lines added for every one that is needed(From the 27 rows the code added, row number 11,15,19;20,24,28;29,33,37 are the exact data I need.). I think instead of trying to explain, I'm going to ask you to have a look at the columns that I highlighted in orange. The red text are data that I posted manually. It is only 9 lines. The code gives 27 lines. Also note that the order of the entries in the green column is not corresponding to the correct info in WSH 2 Column D to F
There was one "/10" that I already added to the IF formula.
Thank you so much for all the help.
Kind regards
My apologies, I misunderstood what you wanted. Try this version:
Sub CopyToRecords() Dim wsh1 As Worksheet Dim wsh2 As Worksheet Dim r1 As Long, r2 As Long Dim m1 As Long, m2 As Long Dim n2 As Long Dim n As Long Application.ScreenUpdating = False Set wsh1 = Worksheets("Spray instruction PL") Set wsh2 = Worksheets("Records.") m1 = wsh1.Range("A26").End(xlUp).Row m2 = wsh1.Range("F26").End(xlUp).Row n2 = m2 - 15 n = wsh2.Range("A" & wsh2.Rows.Count).End(xlUp).Row + 1 For r1 = 16 To m1 For r2 = 16 To m2 wsh2.Range("A" & n).Resize(n2).Value = wsh1.Range("U" & r2).Value wsh2.Range("B" & n).Resize(n2).Value = wsh1.Range("B" & r2).Value wsh2.Range("C" & n).Resize(n2).Value = wsh1.Range("C" & r2).Value wsh2.Range("D" & n).Resize(n2).Value = wsh1.Range("F" & r1).Resize(n2).Value wsh2.Range("E" & n).Resize(n2).Value = wsh1.Range("G" & r1).Resize(n2).Value wsh2.Range("F" & n).Resize(n2).Value = wsh1.Range("H" & r1).Resize(n2).Value With wsh2.Range("G" & n).Resize(n2) .Formula = "='Spray instruction PL'!L16*" & _ "IF(OR('Spray instruction PL'!N16={""KG"",""L""}),1000,1)/10" .Value = .Value End With wsh2.Range("I" & n).Resize(n2).Value = wsh1.Range("O" & r1).Resize(n2).Value wsh2.Range("L" & n).Resize(n2).Value = wsh1.Range("R" & r1).Resize(n2).Value wsh2.Range("M" & n).Resize(n2).Value = wsh1.Range("M11").Value With wsh2.Range("N" & n).Resize(n2) .Formula = "=TEXTJOIN("","",TRUE,'Spray instruction PL'!$K$8," & _ "'Spray instruction PL'!$K$7,'Spray instruction PL'!$K$6)" .Value = .Value End With wsh2.Range("O" & n).Resize(n2).Value = wsh1.Range("T" & r2).Value With wsh2.Range("Q" & n).Resize(n2) .Formula = "=TEXTJOIN("","",TRUE,'Spray instruction PL'!$G$8," & _ "'Spray instruction PL'!$G$7,'Spray instruction PL'!$G$6)" .Value = .Value End With wsh2.Range("U" & n).Resize(n2).Value = wsh1.Range("E" & r2).Value wsh2.Range("V" & n).Resize(n2).Value = wsh1.Range("F5").Value wsh2.Range("W" & n).Resize(n2).Value = wsh1.Range("D" & r2).Value wsh2.Range("X" & n).Resize(n2).Value = wsh1.Range("O8").Value wsh2.Range("Y" & n).Resize(n2).Value = wsh1.Range("P8").Value n = n + n2 Next r2 Next r1 Application.ScreenUpdating = True End Sub
