Next empty row and Looping

[gasper21]

Hi, I hope someone can help me with this code. I’m trying to make it paste the information to summary sheet and then copy the same information from other worksheet. There are 15 worksheets in one workbook. Here is my code. Thank you in advance for your help.

Sub SearchForString()

Dim wsSource As Worksheet'Active worksheet
Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr As String

On Error GoTo Err_Execute

'Populate the array for the outer loop search for values
arr = Array("Total Revenue", "Net Revenue to the WI Owners", "Total WI Expenses", "Average $ per BBL")

Set wsSource = ActiveSheet'Active worksheet

'outer loop through the array
For a = LBound(arr) To UBound(arr)
'locate first instance
Set fnd = Columns("B").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
'record address of first find
addr = fnd.Address
'seed the cpy range object
If cpy Is Nothing Then Set cpy = fnd.EntireRow
Do
'build union
Set cpy = Union(cpy, fnd.EntireRow)

'look for another
Set fnd = Columns("B").FindNext(after:=fnd)

'keep finding new matches until it loops back to the first
Loop Until fnd.Address = addr
End If
Next a

With Worksheets("Summary")
'one stop copy & paste operation
cpy.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

Exit Sub

Err_Execute:
Debug.Print Now & " " & Err.Number & " - " & Err.Description

End Sub

 

[JoeMo]

Re: Next empty row and Looping through multiple worksheets

Found another error after devising a couple of sheets that let me test the code. This is lightly tested, but see if it works for you.

Sub SearchForString()
Dim wsSource As Worksheet
Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr As String
On Error GoTo Err_Execute
'Populate the array for the outer loop search for values
arr = Array("Total Revenue", "Net Revenue to the WI Owners", "Total WI Expenses", "Average $ per BBL")
For Each wsSource In ThisWorkbook.Worksheets
    If wsSource.Name <> "Summary" Then
        'outer loop through the array
        For a = LBound(arr) To UBound(arr)
            'locate first instance
            Set fnd = wsSource.Columns("B").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            If Not fnd Is Nothing Then
                'record address of first find
                addr = fnd.Address
                'seed the cpy range object
                If cpy Is Nothing Then Set cpy = fnd.EntireRow
                Do
                    'build union
                    Set cpy = Union(cpy, fnd.EntireRow)
                    
                    'look for another
                    Set fnd = wsSource.Columns("B").FindNext(after:=fnd)
                    
                    'keep finding new matches until it loops back to the first
                Loop Until fnd.Address = addr
            End If
        Next a
        With Worksheets("Summary")
            If Not cpy Is Nothing Then
            'one stop copy & paste operation
                cpy.Copy Destination:=.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).EntireRow
            End If
        End With
    End If
    Set cpy = Nothing
Next wsSource
Exit Sub
Err_Execute:
Debug.Print Now & " " & Err.Number & " - " & Err.Description
End Sub

 

[gasper21]

Re: Next empty row and Looping through multiple worksheets

After lots of research I was able to find a solution for my macro..