VBA code to search,copy, paste data from all sheets in the same workbook

[AbdulAli]

hello every one i am new to VBA the attach file vba code which works fine but i want to modify it for other workbook it search on only one sheet and only the first occurrence ( i want it to search 8 sheets in the same workbook) it paste the data over the old searched data ( it should find the last row and paste the new data) any kind of help is appreciated thanks in advance

Sub test()

Dim sheetPaste As Worksheet
Dim sheetTarget As Worksheet
Dim sheetToSearch As Worksheet
Dim x As String

Dim columnValue As String: columnValue = "A"
Dim rowValue As Integer: rowValue = 1
Dim LTargetRow As Long
Dim maxRowToTarget As Long: maxRowToTarget = 1000

Dim columnToSearch As String: columnToSearch = "V"
Dim iniRowToSearch As Integer: iniRowToSearch = 1

Dim LSearchRow As Long
Dim maxRowToSearch As Long: maxRowToSearch = 1000

LCopyToRow = 1

Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
Set sheetToSearch = ThisWorkbook.Worksheets("1")


'MsgBox sheetTarget.Cells(Rows.Count, 20).End(xlUp).Row
'finds the last row with a value in it in column T of sheetTarget
For LTargetRow = rowValue To sheetTarget.Cells(Rows.Count, 20).End(xlUp).Row

    'targetCell = columValue & CStr(LTargetRow)
    'must set x = , not the value in the column = to x (which is not initialize to it is "")
    If sheetTarget.Range(columnValue & CStr(LTargetRow)).Text <> "" Then
        x = sheetTarget.Range(columnValue & CStr(LTargetRow)).Text

        'finds the last row with a value in it in column A of sheetToSearch
        For LSearchRow = iniRowToSearch To sheetToSearch.Cells(Rows.Count, 1).End(xlUp).Row
            If sheetToSearch.Range(columnToSearch & CStr(LSearchRow)).Value = x Then

                sheetToSearch.Rows(LSearchRow).Copy

                sheetPaste.Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues

                LCopyToRow = LCopyToRow + 1

                Exit For

            End If
           'dont need this anymore now that we know that last row with data in it.
    '        If (LSearchRow >= maxRowToSearch) Then
    '            Exit For
    '        End If

        Next LSearchRow
    End If

'If (LTargetRow >= maxRowToTarget) Then
'     Exit For
'End If
Next LTargetRow

'Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row

End Sub

 

[AbdulAli]

I don't understand exactly what you want the macro to extract. Please upload a file showing your expected results in sheetPaste based on the data in sheetTarget.

in this link (expacted results.xlsm) i have designed the expected results manually
the code should search the name in (targetsheet) A1 cell for example (A1)contain ( Noor ) in all sheets in the work book and than copy the row to (pasted sheets)

 

[mumps]

Try:

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim LastRow As Long, Val As Range, fnd As Range, sAddr As String, lCol As Long
    Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
    Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
    For Each sheetToSearch In Sheets
        If sheetToSearch.Name <> "sheetTarget" And sheetToSearch.Name <> "sheetPaste" Then
            For Each Val In sheetTarget.Range("A1", sheetTarget.Range("A" & sheetTarget.Rows.Count).End(xlUp))
                If Val <> "" Then
                    Set fnd = sheetToSearch.Range("T:T").Find(Val.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        sAddr = fnd.Address
                        Do
                            LastRow = sheetPaste.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                            lCol = sheetToSearch.Cells(2, Columns.Count).End(xlToLeft).Column
                            sheetToSearch.Range("E" & fnd.Row).Resize(, lCol - 4).Copy
                            sheetPaste.Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            Set fnd = sheetToSearch.Range("T:T").FindNext(fnd)
                        Loop While fnd.Address <> sAddr
                        sAddr = ""
                    End If
                End If
            Next Val
        End If
    Next sheetToSearch
    Application.ScreenUpdating = True
End Sub

 

[AbdulAli]

Try:

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim LastRow As Long, Val As Range, fnd As Range, sAddr As String, lCol As Long
    Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
    Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
    For Each sheetToSearch In Sheets
        If sheetToSearch.Name <> "sheetTarget" And sheetToSearch.Name <> "sheetPaste" Then
            For Each Val In sheetTarget.Range("A1", sheetTarget.Range("A" & sheetTarget.Rows.Count).End(xlUp))
                If Val <> "" Then
                    Set fnd = sheetToSearch.Range("T:T").Find(Val.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        sAddr = fnd.Address
                        Do
                            LastRow = sheetPaste.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                            lCol = sheetToSearch.Cells(2, Columns.Count).End(xlToLeft).Column
                            sheetToSearch.Range("E" & fnd.Row).Resize(, lCol - 4).Copy
                            sheetPaste.Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            Set fnd = sheetToSearch.Range("T:T").FindNext(fnd)
                        Loop While fnd.Address <> sAddr
                        sAddr = ""
                    End If
                End If
            Next Val
        End If
    Next sheetToSearch
    Application.ScreenUpdating = True
End Sub

bro the above code results the same it copies all data in all sheets without distinguish

 

[mumps]

Try:

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim LastRow As Long, Val As Range
    Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
    Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
    For Each Val In sheetTarget.Range("A1", sheetTarget.Range("A" & sheetTarget.Rows.Count).End(xlUp))
        If Val <> "" Then
            For Each sheetToSearch In Sheets
                If sheetToSearch.Name <> "sheetTarget" And sheetToSearch.Name <> "sheetPaste" Then
                    With sheetToSearch
                        .Cells(2, 5).AutoFilter 16, Val
                        If .Range("T2") = Val Then
                            .AutoFilter.Range.Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        Else
                             .AutoFilter.Range.Offset(1).Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        End If
                    End With
                End If
            Next sheetToSearch
        End If
    Next Val
    Application.ScreenUpdating = True
End Sub

This macro is based on the file you posted. If the data in your actual file is not organized in exactly the same way, the macro will not work properly.

 

[AbdulAli]

Try:

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim LastRow As Long, Val As Range
    Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
    Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
    For Each Val In sheetTarget.Range("A1", sheetTarget.Range("A" & sheetTarget.Rows.Count).End(xlUp))
        If Val <> "" Then
            For Each sheetToSearch In Sheets
                If sheetToSearch.Name <> "sheetTarget" And sheetToSearch.Name <> "sheetPaste" Then
                    With sheetToSearch
                        .Cells(2, 5).AutoFilter 16, Val
                        If .Range("T2") = Val Then
                            .AutoFilter.Range.Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        Else
                             .AutoFilter.Range.Offset(1).Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        End If
                    End With
                End If
            Next sheetToSearch
        End If
    Next Val
    Application.ScreenUpdating = True
End Sub

This macro is based on the file you posted. If the data in your actual file is not organized in exactly the same way, the macro will not work properly.

thank you Bro it works you are brilliant you have made my work very very easy and quick one more request please can you please document the important parts of the code for future adjustments

 

[AbdulAli]

Try:

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim LastRow As Long, Val As Range
    Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
    Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
    For Each Val In sheetTarget.Range("A1", sheetTarget.Range("A" & sheetTarget.Rows.Count).End(xlUp))
        If Val <> "" Then
            For Each sheetToSearch In Sheets
                If sheetToSearch.Name <> "sheetTarget" And sheetToSearch.Name <> "sheetPaste" Then
                    With sheetToSearch
                        .Cells(2, 5).AutoFilter 16, Val
                        If .Range("T2") = Val Then
                            .AutoFilter.Range.Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        Else
                             .AutoFilter.Range.Offset(1).Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        End If
                    End With
                End If
            Next sheetToSearch
        End If
    Next Val
    Application.ScreenUpdating = True
End Sub

This macro is based on the file you posted. If the data in your actual file is not organized in exactly the same way, the macro will not work properly.

can i use the same code if my data is in like below table (in picture ) i this table after every row their is more 2 empty rows when i run the same code in this table it gets error --- and error code line is ( .Cells(2, 5).AutoFilter 16, Val ) <---- why it gives error

 

[mumps]

The code will not work if your data is organized that way. Please review my comment from a previous post.

This macro is based on the file you posted. If the data in your actual file is not organized in exactly the same way, the macro will not work properly.

Here is the macro with explanatory comments:

Sub Button1_Click()
    Application.ScreenUpdating = False
    Dim LastRow As Long, Val As Range
    Set sheetPaste = ThisWorkbook.Worksheets("sheetPaste")
    Set sheetTarget = ThisWorkbook.Worksheets("sheetTarget")
    For Each Val In sheetTarget.Range("A1", sheetTarget.Range("A" & sheetTarget.Rows.Count).End(xlUp))
        If Val <> "" Then
            For Each sheetToSearch In Sheets
                If sheetToSearch.Name <> "sheetTarget" And sheetToSearch.Name <> "sheetPaste" Then
                    With sheetToSearch
                        .Cells(2, 5).AutoFilter 16, Val 'filters each sheet based on the value of A1 in sheetTarget
                        If .Range("T2") = Val Then 'This 'If' section is necessary because there are no headers in the sheets
                                        'It includes line 2 if cell T2 contains the value of A1 in sheetTarget
                            .AutoFilter.Range.Copy 'copies the visible rows after filtering
                            With sheetPaste 'pastes to sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter 'removes thr filter
                        Else 'This 'Else' section excludes line 2 if cell T2 does not contain the value of A1 in sheetTarget
                             .AutoFilter.Range.Offset(1).Copy
                            With sheetPaste
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                                lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
                                .Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
                            End With
                            .Range("E2").AutoFilter
                        End If
                    End With
                End If
            Next sheetToSearch
        End If
    Next Val
    Application.ScreenUpdating = True
End Sub