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]

Untested. Is this what you want?

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
    If wsSource <> "Summary" Then
        '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
    End If
    Set cpy = Nothing
Next wsSource
Exit Sub
Err_Execute:
Debug.Print Now & " " & Err.Number & " - " & Err.Description
End Sub

 

[gasper21]

Next empty row and Looping through multiple worksheets

Hello JoeMO Thank you for your respond, I need to be able to search for these values on multiple worksheets within the same workbook and then paste the information ether in the last row of the same worksheet, I'm lost on what I need to do.

I sincerely appropriate your assistance

("Total Revenue", "Net Revenue to the WI Owners", "Total WI Expenses", "Average $ per BBL")

 

[JoeMo]

Re: Next empty row and Looping through multiple worksheets

Did you try the code I posted?

 

[gasper21]

Re: Next empty row and Looping through multiple worksheets

Yes Sir, however the code is not doing anything, it just move to the summary sheet without copying the values

 

[gasper21]

Re: Next empty row and Looping through multiple worksheets

Love your comment, I’m an old man and still don’t know what I’m doing ?

 

[JoeMo]

Re: Next empty row and Looping through multiple worksheets

Yes Sir, however the code is not doing anything, it just move to the summary sheet without copying the values

Could be none of your search terms are found. As I said in my initial post, I didn't test this. I'd be willing to test it if you post some sample data for at least a couple of worksheets in a format that can be copied from a browser and pasted to Excel.

Otherwise, you could try stepping through the code using the F8 key to see if the range variable fnd is Nothing.

 

[gasper21]

Re: Next empty row and Looping through multiple worksheets

JoeMO, I'm still new to this website and I don't know how to attache my sample. I know for sure all values are on each worksheet. I recorded a macro that is doing the job however I have to do it the old fashion way, run the macro each time and call the other.

Please see my sample.

Sub Test1()


Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Total Revenue:" Then
Cell.EntireRow.Copy
Range("A80").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False


End If
Next
Call Test2
End Sub


Sub Test2()


Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Net Revenue to the WI Owners" Then
Cell.EntireRow.Copy
Range("A81").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False


End If
Next
Call Test3
End Sub


Sub Test3()


Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Total WI Expenses" Then
Cell.EntireRow.Copy
Range("A82").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False


End If
Next
Call Test4
End Sub


Sub Test4()


Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Average $ per BBL" Then
Cell.EntireRow.Copy
Range("A83").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False


End If
Next
Call Post5
End Sub


Sub Post5()


For Each Cell In Range("A80:N83")
If Cell.Value < 0 Then
Cell.Value = Abs(Cell.Value)
End If
Next Cell


End Sub

 

[JoeMo]

Re: Next empty row and Looping through multiple worksheets

To post your sample data you can use one of the links below:

Excel Jeanie link: https://excel-code-jeanie.software.informer.com/1.0/
MrExcel HTML Maker link: http://www.mrexcel.com/forum/2545970-post2.html

 

[JoeMo]

Re: Next empty row and Looping through multiple worksheets

After another look at the code I posted, I noticed an error in one line. See if this does what you want:

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
    If wsSource.Name <> "Summary" Then
        '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
    End If
    Set cpy = Nothing
Next wsSource
Exit Sub
Err_Execute:
Debug.Print Now & " " & Err.Number & " - " & Err.Description
End Sub