VBA code to count, copy, paste, last row, if

[Kettie]

Good evening

I have only trained myself in excel VBA and have been able to learn very much from other peoples questions.

I need a code to copy the data in image 1 (Sheet1) to the table in image 2 (Sheet2).

The code has to:
1. Count the amount of cells used in column c
2. Copy the counted (in step 1) amount of cells in column c,d and e
3. Paste in last row +1 in sheet2 in column c,d and e
4. The date and name in column a and b should be added to every row that is pasted
5. This has to be done for every used cell found in column b

English is not my first language. Excuse me if the explanation is difficult to understand.

Thanks

[#2 · Accepted solution]

@Kettie 

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

[#3]

@HansVogelaar Thank you very much for the quick reply and the help. It works exactly as I hoped. 

Would you please help me to modify it so that it:

1. Counts only in a set range in sheet 1 i.e A8:A18

2. Copy the data in wsh1 A2, B2, A4, B4 to wsh2 column G,H,I,J

3. IF wsh1 column G is in g : value in wsh1 column F/1000 and paste in wsh2 column F.

4. IF wsh1 column G is in kg : Copy value in wsh1 column F and paste in wsh2 column F.

Thank you 

[#4]

@Kettie 

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

[#5]

@HansVogelaar 

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.")

1. Count the amount of cells used in wsh1 F16:F25
2. 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

1.  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

1. 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

[#6]

@Kettie 

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 Sub

[#7]

Good 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

[#8]

@Kettie 

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

[#9]

Thanks again @HansVogelaar. I am very close now. Everything goes to the correct place, but I got stuck again. The process gets repeated with the amout of what seems to be the count of column b * count of column f * count of column f (6*4*4=96 entries) only 24 is needed. The entries in red are needed, the rest in black are duplicates.

Please advise

[#10]

@Kettie 

Is this better? (I'm a bit confused by the changes that you applied)

Sub CopyToRecordPL()
    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
    Dim n3 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("B26").End(xlUp).Row
    m3 = wsh1.Range("F26").End(xlUp).Row
    n3 = m3 - 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(n3).Value = wsh1.Range("U" & r2).Value
                wsh2.Range("B" & n).Resize(n3).Value = wsh1.Range("B" & r2).Value
                ' Shouldn't KULTIVAR be copied?
                wsh2.Range("D" & n).Resize(n3).Value = wsh1.Range("F" & r1).Resize(n3).Value
                wsh2.Range("E" & n).Resize(n3).Value = wsh1.Range("G" & r1).Resize(n3).Value
                wsh2.Range("F" & n).Resize(n3).Value = wsh1.Range("H" & r1).Resize(n3).Value
                With wsh2.Range("G" & n).Resize(n3)
                    .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(n3).Value = wsh1.Range("O" & r1).Resize(n3).Value
                wsh2.Range("L" & n).Resize(n3).Value = wsh1.Range("R" & r1).Resize(n3).Value
                wsh2.Range("M" & n).Resize(n3).Value = wsh1.Range("M11").Value
                With wsh2.Range("N" & n).Resize(n3)
                    .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(n3).Value = wsh1.Range("T" & r2).Value
                With wsh2.Range("Q" & n).Resize(n3)
                    .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(n3).Value = "PL" & wsh1.Range("F5").Value
                wsh2.Range("Y" & n).Resize(n3).Value = wsh1.Range("P8").Value
                ' I don't understand the following - column AB is empty
                ' wsh2.Range("AA" & n).Resize(n3).Value = wsh1.Range("AB" & r1).Resize(n3).Value
                n = n + n3
        Next r2
    Next r1
    Application.ScreenUpdating = True
End Sub

[#11]

Thank you very much @HansVogelaar. It seems that this code does the Job (I made small changes, but are happy with how they worked out). Sorry for the confusion. I worked on the layout of the original and did not apply them to the template. I added them now.

I found another problem that I need help with please. I added a macro called NextsprayinstructionPL(). This needs to be run before copytorecordsPL. The problem that is creates, is that it changes the name and then copytorecordsPL does not apply to it anymore. Is it dangerous to use "active sheet" in "copytorecordsPL" or do you have another plan for me please?

[#12]

@Kettie 

If you make sure that the sheet you want to use instead of Spray Instructions PL is the active sheet when you run CopyToRecordPL, you can change the line

Set wsh1 = Worksheets("Spray instruction PL")

in CopyToRecordPL to

Set wsh1 = ActiveSheet

[#13]

Thank you. What can we do regarding the formula in CopytorecordsPL that refers to spray instruction PL?

[#14]

@Kettie 

Like this:

Sub CopyToRecordPL()
    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
    Dim n3 As Long
    Dim n As Long
    Application.ScreenUpdating = False
    Set wsh1 = ActiveSheet
    Set wsh2 = Worksheets("Records")
    m1 = wsh1.Range("A26").End(xlUp).Row
    m2 = wsh1.Range("B26").End(xlUp).Row
    m3 = wsh1.Range("F26").End(xlUp).Row
    n3 = m3 - 15
    n = wsh2.Range("b" & wsh2.Rows.Count).End(xlUp).Row + 1
    For r1 = 16 To m1
        For r2 = 16 To m2
                wsh2.Range("A" & n).Resize(n3).Value = wsh1.Range("U" & r2).Value
                wsh2.Range("B" & n).Resize(n3).Value = wsh1.Range("B" & r2).Value
                wsh2.Range("AA" & n).Resize(n3).Value = wsh1.Range("AB" & r1).Resize(n3).Value
                wsh2.Range("D" & n).Resize(n3).Value = wsh1.Range("F" & r1).Resize(n3).Value
                wsh2.Range("E" & n).Resize(n3).Value = wsh1.Range("G" & r1).Resize(n3).Value
                wsh2.Range("F" & n).Resize(n3).Value = wsh1.Range("H" & r1).Resize(n3).Value
                With wsh2.Range("G" & n).Resize(n3)
                    .Formula = "='" & wsh1.Name & "'!L16*" & _
                        "IF(OR('" & wsh1.Name & "'!N16={""KG"",""L""}),1000,1)/10"
                    .Value = .Value
                End With
                wsh2.Range("I" & n).Resize(n3).Value = wsh1.Range("O" & r1).Resize(n3).Value
                wsh2.Range("L" & n).Resize(n3).Value = wsh1.Range("R" & r1).Resize(n3).Value
                wsh2.Range("M" & n).Resize(n3).Value = wsh1.Range("M11").Value
                With wsh2.Range("N" & n).Resize(n3)
                    .Formula = "=TEXTJOIN("","",TRUE,'" & wsh1.Name & "'!$K$8," & _
                        "'" & wsh1.Name & "'!$K$7,'" & wsh1.Name & "'!$K$6)"
                    .Value = .Value
                End With
                wsh2.Range("O" & n).Resize(n3).Value = wsh1.Range("T" & r2).Value
                With wsh2.Range("Q" & n).Resize(n3)
                    .Formula = "=TEXTJOIN("","",TRUE,'" & wsh1.Name & "'!$G$8," & _
                        "'" & wsh1.Name & "'!$G$7,'" & wsh1.Name & "'!$G$6)"
                    .Value = .Value
                End With
                wsh2.Range("V" & n).Resize(n3).Value = "PL" & wsh1.Range("F5").Value
                wsh2.Range("Y" & n).Resize(n3).Value = wsh1.Range("P8").Value
                n = n + n3
        Next r2
    Next r1
    Application.ScreenUpdating = True
End Sub