Search copy row improvement.

[Clayraw]

Hi all,

I have been doing some coding and got a fair bit working. Now I use a "search copy entire row" macro which works fine for 1 sheet, but I want to apply this coding to other (3 sheets) as well without having to retype the lookup string into the inputbox. The lookup column stays the same and is located in column A on each sheet. Till now I didn't manage to get it working, it seems it doesn't see "Strtofind" as a string, at least, just for the first sheet. Please do not hesitate if you have any further improvements.

 'Find copy row'
    Dim strLastRow As String
    Dim rngC As Range
    Dim Strtofind As String, FirstAddress As String
    Dim wSht2 As Worksheet
    Dim wSht1 As Worksheet
    Dim rngtest As String
    Application.ScreenUpdating = False

    'Define workbooks - vendor and macro file'
    Dim wb1 As Excel.Workbook
    Set wb1 = Workbooks("Template required information from VENDOR NEW -product category management.xlsx")
    Dim wb2 As Excel.Workbook
    Set wb2 = Workbooks("Macro file 2.xlsm")
    
    'Define worksheets names'
    Set wSht2 = wb2.Sheets("Sheet2")
    Set wSht4 = wb2.Sheets("Sheet3")
    Set wSht6 = wb2.Sheets("Sheet4")
    Set wSht8 = wb2.Sheets("Sheet5")
    Set wSht1 = wb1.Sheets(" 3. MANDATORY ERP DATA")
    Set wSht3 = wb1.Sheets("5. DESCRIPTIONS")
    Set wSht5 = wb1.Sheets("4. AVAILABILITY PER COUNTRY")
    Set wSht7 = wb1.Sheets("6. ASSETS")
    
    'Define lookup range & paste sheet ERP'
     Strtofind = InputBox("Enter manufacturer part no.", "Copy rows to Group/Measure file")
        With wSht1.Range("A2:A5000")
            Set rngC = .Find(What:=Strtofind, LookAt:=xlWhole)
            If Not rngC Is Nothing Then
                FirstAddress = rngC.Address
                    Do
                    strLastRow = wSht2.Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy wSht2.cells(strLastRow, 1)
                    Set rngC = .FindNext(rngC)
                Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
            End If
    End With
    
    'Define lookup range & paste sheet DESCRIPTIONS'
        With wSht3.Range("A2:A5000")
            Set rngC = .Find(What:=Strtofind, LookAt:=xlWhole)
            If Not rngC Is Nothing Then
                FirstAddress = rngC.Address
                    Do
                    strLastRow = wSht4.Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy wSht2.cells(strLastRow, 1)
                    Set rngC = .FindNext(rngC)
                Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
            End If
    End With
    
    'Define lookup range & paste sheet AVAILABILITY'
        With wSht5.Range("A2:A5000")
            Set rngC = .Find(What:=Strtofind, LookAt:=xlWhole)
            If Not rngC Is Nothing Then
                FirstAddress = rngC.Address
                    Do
                    strLastRow = wSht6.Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy wSht2.cells(strLastRow, 1)
                    Set rngC = .FindNext(rngC)
                Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
            End If
    End With
    
     'Define lookup range & paste sheet ASSETS'
        With wSht7.Range("A2:A5000")
            Set rngC = .Find(What:=Strtofind, LookAt:=xlWhole)
            If Not rngC Is Nothing Then
                FirstAddress = rngC.Address
                    Do
                    strLastRow = wSht8.Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy wSht2.cells(strLastRow, 1)
                    Set rngC = .FindNext(rngC)
                Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
            End If
    End With

Many thanks in advance.

Clayraw

 

[Clayraw]

It seems that the "search" function doesn't work at all atm.

 

[Clayraw]

bump

 

[Clayraw]

Could anyone have a look at this please?