VBA to Create Summary Sheet

[Topher177]

Hello. I'm looking to create a VBA code that will loop through every worksheet within my workbook (except for the summary sheet) and search for a text string. Once this string is found, I would like the code to grab the 5 cell rows to the right of the looked up cell and paste special this information on a summary sheet. Please help.

 

[Smitty]

Welcome to the Board!

I'd start by recording a macro on a few sheets. You can post the resulting code back here for everyone to take a loot.

 

[JackDanIce]

Change part in blue and try:

Sub UpdateSummary()

    Dim ws      As Worksheet
    Dim wsSum   As Worksheet
    
    Dim rng     As Range
    
    Dim x       As Long
    Dim LR      As Long
    
    Const FindString As String = "xxxxx"
    
    Set wsSum = Sheets("Summary")
    LR = wsSum.Cells(rows.count, 1).End(xlUp).row + 1
    
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If .Name <> wsSum.Name Then
                Set rng = .Cells.Find(what:=FindString, LookIn:=xlValues)
                
                If Not rng Is Nothing Then
                    wsSum.Cells(LR, 1).value = rng.Offset(0, 5).value
                    LR = LR + 1
                    Set rng = Nothing
                End If
                
            End If
        End With
    Next ws
    
    wsSum.Select
    
    Application.ScreenUpdating = False
    
    Set wsSum = Nothing

End Sub

 

[Topher177]

JackDanIce - Thank you for your help! The code you posted works great except that it is currently only returning the 5th cell from each table. I'm sorry if I wasn't clear but I will need to copy the whole range (5 cells) to the right of the unique identifier.

 

[JackDanIce]

Experiment with parts in blue and try:

Sub UpdateSummary()

    Dim ws      As Worksheet
    Dim wsSum   As Worksheet
    
    Dim rng     As Range
    
    Dim x       As Long
    Dim LR      As Long
    
    Const FindString As String = "xxxxx"
    
    Set wsSum = Sheets("Summary")
    LR = wsSum.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If .Name <> wsSum.Name Then
                Set rng = .Cells.Find(what:=FindString, LookIn:=xlValues)
                
                If Not rng Is Nothing Then
                    wsSum.Cells(LR, 1).Value = rng.Resize(1, 5).Value
                    LR = LR + 1
                    Set rng = Nothing
                End If
                
            End If
        End With
    Next ws
    
    wsSum.Select
    
    Application.ScreenUpdating = False
    
    Set wsSum = Nothing

End Sub