Code to copy over row if certain criteria is met

[joyrichter]

Good day

I need help with the following code;

I need to copy rows from one sheet to another sheet if certain information on the first sheet appears on 2 other sheets, the rows on the first sheets should automatically copy if the criteria is met.

For example: if Cell A1 in sheet 1(Non moving stock) = cdx123 and cdx123 appears on sheet 2 (Eindvoorraad) and sheet 3 (GRN), the information that is in the row of A on sheet 1 needs to copy over to a recon sheet.

This is the code I have managed to write so far:




'purpose: to consolidate the obeslete stock into one worksheet

'step 1: declare the worksheet variables
Dim wsRecon As Worksheet
Dim wsNon_moving_stock As Worksheet
Dim wsEindvoorraad As Worksheet
Dim wsGRN As Worksheet


'step 2: assign worksheets to the above variables
Set wsRecon = Worksheets("Recon")
Set wsNon_moving_stock = Worksheets("Non_Moving_Stock")
Set wsEindvoorraad = Worksheets("Eindvoorraad")
Set wsGRN = Worksheets("GRN")



'Step3: Declare last row variables
Dim lastrow_Recon As Long
Dim lastrow_Non_moving_Stock As Long
Dim lastrow_Eindvoorraad As Long
Dim lastrow_GRN As Long
Dim Cell As Range
Dim FinalRow As Long

'step4: Determine last rows for Non Moving Stock, Eindvoorraad, GRN

lastrow_Recon = wsRecon.Cells(Rows.Count, 1).End(xlUp).Row
lastrow_Non_moving_Stock = wsNon_moving_stock.Cells(Rows.Count, 1).End(xlUp).Row
lastrow_Eindvoorraad = wsEindvoorraad.Cells(Rows.Count, 1).End(xlUp).Row
lastrow_GRN = wsGRN.Cells(Rows.Count, 1).End(xlUp).Row


With Non_moving_stock

'Apply loop for column A until last cell with value

For Each Cell In .Range("A4:K" & .Cells(.Rows.Count, "A").End(xlUp).Row)

'Apply condition to match the "EINDVORRAAD" value

If Cell.Value = "EINDVOORRAAD" Then

'Command to Copy and move to a destination Sheet "RECON"

.Rows(Cell.Row).Copy Destination:=Recon.Rows(FinalRow2 + 1)

FinalRow2 = FinalRow2 + 1

'Apply condition to match the "GRN" value

ElseIf Cell.Value = "GRN" Then

'Command to Copy and move to a destination Sheet "Recon"

.Rows(Cell.Row).Copy Destination:=Recon.Rows(FinalRow2 + 1)

FinalRow2 = FinalRow2 + 1

End If

Next Cell

End With

Can you please help me

Thanking you in advance

 

[joyrichter]

Hi

I tried the code

An error pops up - Run time error code 9,

This line is highlighted: Set ws1 = Sheets("ClosingStock") 'delete trailing space

when I press debug.

Can you please have a look into what is causing the error?

Thank you

 

[mumps]

The names for that sheet and the GRN sheets have trailing spaces. Double click the sheet names and remove those extra spaces.

 

[joyrichter]

The names for that sheet and the GRN sheets have trailing spaces. Double click the sheet names and remove those extra spaces.

Thank you I will do that

 

[joyrichter]

Thank you so much the code works perfectly.

 

[mumps]

You are very welcome.

 

[joyrichter]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim v1 As Variant, v2 As Variant, v3 As Variant, dic As Object, i As Long, ii As Long
    Set srcWS = Sheets("NonMovingStock")
    Set desWS = Sheets("Recon")
    Set ws1 = Sheets("ClosingStock") 'delete trailing space
    Set ws2 = Sheets("GRN") 'delete trailing space
    v1 = srcWS.Range("A5", srcWS.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = ws1.Range("C2", ws1.Range("C" & Rows.Count).End(xlUp)).Value
    v3 = ws2.Range("I1", ws2.Range("I" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 4
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            For ii = LBound(v3) To UBound(v3)
                If dic.exists(v2(i, 1)) Then
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 7).Value = srcWS.Range("A" & dic(v2(i, 1))).Resize(, 7).Value
                    Exit For
                End If
            Next ii
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Good day

Thank you for your help with the above code, I am trying to tweek the code bit so that the value on the closing stock under column I is also copied to the recon sheet when the code is run, but for some reason the first 5 lines do not copy over to the recon sheet.

I tweeked the code as follows:
Sub CopyRow()
Application.ScreenUpdating = False
Dim srcWS As Worksheet, desWS As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim v1 As Variant, v2 As Variant, v3 As Variant, dic As Object, i As Long, ii As Long
Set srcWS = Sheets("NonMovingStock")
Set desWS = Sheets("Recon")
Set ws1 = Sheets("ClosingStock") 'delete trailing space
Set ws2 = Sheets("GRN") 'delete trailing space
v1 = srcWS.Range("A5", srcWS.Range("A" & Rows.Count).End(xlUp)).Value
v2 = ws1.Range("C2", ws1.Range("C" & Rows.Count).End(xlUp)).Value
v3 = ws2.Range("I1", ws2.Range("I" & Rows.Count).End(xlUp)).Value
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(v1) To UBound(v1)
If Not dic.exists(v1(i, 1)) Then
dic.Add v1(i, 1), i + 4
End If
Next i
For i = LBound(v2) To UBound(v2)
If dic.exists(v2(i, 1)) Then
For ii = LBound(v3) To UBound(v3)
If dic.exists(v2(i, 1)) Then
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 7).Value = ws1.Range("C" & dic(v2(i, 1))).Resize(, 7).Value
Exit For
End If
Next ii
End If
Next i
Application.ScreenUpdating = True
End Sub



Can you please help me with this issue.

Thank you

 

[mumps]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim v1 As Variant, v2 As Variant, v3 As Variant, dic As Object, i As Long, ii As Long
    Set srcWS = Sheets("NonMovingStock")
    Set desWS = Sheets("Recon")
    Set ws1 = Sheets("ClosingStock") 'delete trailing space
    Set ws2 = Sheets("GRN") 'delete trailing space
    v1 = srcWS.Range("A5", srcWS.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = ws1.Range("C2", ws1.Range("C" & Rows.Count).End(xlUp)).Value
    v3 = ws2.Range("I1", ws2.Range("I" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 4
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            For ii = LBound(v3) To UBound(v3)
                If dic.exists(v2(i, 1)) Then
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 7).Value = srcWS.Range("A" & dic(v2(i, 1))).Resize(, 7).Value
                    desWS.Cells(desWS.Rows.Count, "H").End(xlUp).Offset(1).Value = ws1.Range("I" & i + 1).Value
                    Exit For
                End If
            Next ii
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[joyrichter]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim v1 As Variant, v2 As Variant, v3 As Variant, dic As Object, i As Long, ii As Long
    Set srcWS = Sheets("NonMovingStock")
    Set desWS = Sheets("Recon")
    Set ws1 = Sheets("ClosingStock") 'delete trailing space
    Set ws2 = Sheets("GRN") 'delete trailing space
    v1 = srcWS.Range("A5", srcWS.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = ws1.Range("C2", ws1.Range("C" & Rows.Count).End(xlUp)).Value
    v3 = ws2.Range("I1", ws2.Range("I" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 4
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            For ii = LBound(v3) To UBound(v3)
                If dic.exists(v2(i, 1)) Then
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 7).Value = srcWS.Range("A" & dic(v2(i, 1))).Resize(, 7).Value
                    desWS.Cells(desWS.Rows.Count, "H").End(xlUp).Offset(1).Value = ws1.Range("I" & i + 1).Value
                    Exit For
                End If
            Next ii
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Thank you the code works perfectly now

 

[mumps]

You are very welcome.