Need help searching entire workbook and not just a single sheet-CodePudding

I need help modifying the code below to look through the entire workbook searching for "$" instead of just one. I would love it if it could just search for CGYSR-"##". I have had help putting the code together as I am new to VBA

Here is the code:

Option Explicit

Sub FindPriceTagInformation()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet


With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Fill in the search Value
MyArr = Array("$")

Set NewSh = Sheets("Sheet2")

With Sheets("CGYSR-3").Range("A1:ZZ300")

Rcount = 0

For I = LBound(MyArr) To UBound(MyArr)


Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount   1
NewSh.Cells(Rcount, 3).Value = Rng.Value

NewSh.Cells(Rcount, 2).Value = Rng.Offset(-3, 0).Value
NewSh.Cells(Rcount, 1).Value = Rng.Offset(-5, 0).Value

Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

CodePudding user response：

Please, try the next adapted code:

Sub FindPriceTagInformation()
 Dim FirstAddress As String, MyArr, Rng As Range, Rcount As Long, I As Long
 Dim ws As Worksheet, NewSh As Worksheet

 With Application
    .ScreenUpdating = False
    .EnableEvents = False
 End With

 'Fill in the search Value
 MyArr = Array("$")
 Set NewSh = Sheets("Sheet2")
 Rcount = 0
 For Each ws In ActiveWorkbook.Sheets
    If left(ws.Name, 6) = "CGYSR-" Then
       With ws.Range("A1:ZZ300")
           For I = LBound(MyArr) To UBound(MyArr)
               Set Rng = .Find(What:=MyArr(I), _
                   After:=.cells(.cells.count), _
                   LookIn:=xlValues, _
                   LookAt:=xlPart, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, _
                   MatchCase:=False)
               
               If Not Rng Is Nothing Then
                   FirstAddress = Rng.Address
                   Do
                       Rcount = Rcount   1
                       NewSh.cells(Rcount, 3).value = Rng.value
                       
                       NewSh.cells(Rcount, 2).value = Rng.Offset(-3, 0).value
                       NewSh.cells(Rcount, 1).value = Rng.Offset(-5, 0).value
                       
                       Set Rng = .FindNext(Rng)
                   Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
               End If
           Next I
       End With
    End If
 Next ws
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

CodePudding user response：

Searching in Worksheets

In the workbook containing this code (ThisWorkbook), loops through each worksheet trying to identify the ones whose name starts with a given string (CGYSR-). Then it searches for a $ identifying cells with prices and retrieves these cell's values and the values of two other associated cells (3 and 5 cells above) and writes them to a row in another worksheet (Sheet2).

Option Explicit

Sub FindPriceTagInformation()
    
    Const swsNameBegin As String = "CGYSR-"
    Const srgAddress As String = "A1:ZZ300"
    Const dwsName As String = "Sheet2"
    
    Dim SearchStrings As Variant: SearchStrings = Array("$")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Destination Worksheet
    Dim dws As Worksheet: Set dws = wb.Worksheets(dwsName)
    
    ' You do it once here, so you don't have to do it many times in the loops.
    Dim sCellsCount As Long: sCellsCount = dws.Range(srgAddress).Cells.Count
    Dim npLen As String: npLen = Len(swsNameBegin)
    Dim ssLower As Long: ssLower = LBound(SearchStrings)
    Dim ssUpper As Long: ssUpper = UBound(SearchStrings)
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Dim sws As Worksheet ' Source Worksheet
    Dim srg As Range ' Srouce Range
    Dim sfCell As Range ' Source Found Cell
    Dim slCell As Range ' Source Last Cell
    Dim dr As Long ' Current Destination Row
    Dim ss As Long ' Current Search String
    Dim FirstAddress As String
    
    For Each sws In wb.Worksheets
        ' A 'begins-with' ('Left') comparison where 'StrComp' will return 0 if
        ' the strings are equal. Combined with 'vbTextCompare', it will
        ' ignore case i.e. 'CG=cg'.
        If StrComp(Left(sws.Name, npLen), swsNameBegin, vbTextCompare) = 0 Then
            Set srg = sws.Range(srgAddress)
            Set slCell = srg.Cells(sCellsCount) ' the same for all strings
            For ss = ssLower To ssUpper
                Set sfCell = srg.Find( _
                    What:=SearchStrings(ss), _
                    After:=slCell, _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows)
                If Not sfCell Is Nothing Then ' string was found
                    FirstAddress = sfCell.Address ' to prevent an endless loop
                    Do
                        ' Write to the Destination Worksheet.
                        dr = dr   1
                        dws.Cells(dr, 3).Value = sfCell.Value
                        dws.Cells(dr, 2).Value = sfCell.Offset(-3, 0).Value
                        dws.Cells(dr, 1).Value = sfCell.Offset(-5, 0).Value
                        ' Find next string.
                        Set sfCell = srg.FindNext(sfCell)
                    ' Note that in this case, 'sfCell' will never ever
                    ' be 'Nothing' once it's 'something'. The 'Find' method
                    ' doesn't 'know' where it found the first: it just finds
                    ' the next even if it's the same (it goes round and round)
                    ' i.e. if there is one cell to find,
                    ' it will find it 'forever'.
                    ' That's the reason behind comparing with the first address.
                    Loop While sfCell.Address <> FirstAddress
                    Set sfCell = Nothing ' reset for the next string
                'Else ' string was not found
                End If
            Next ss
        End If
    Next sws
    
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With

    'Inform: useful for short and long operations.
    MsgBox "Retrieved price tag information.", vbInformation

End Sub