Complicated Excel VBA Macro with Loop

Question

Hi all.

I require help with a reasonably complicated VBA macro loop for a dataset I've been provided. The dataset exists as one long column one thousands of different entries.

I've tried recording macros but I am at a loss at the best way to approach it. Any help would be greatly appreciated. In its simplest terms, I need to locate a term (ie. "THIS IS A TEST"), copy that cell into new worksheet, go 72 cells up and copy whatever is in that cell into the new worksheet as well.

Logic for the VBA macro Loop...

1. Scan through all worksheets for the words "THIS IS A TEST"
2. Copy that cell into a new worksheet (eg. A1)
3. Go 72 cells up
4. Copy that cell into the new worksheet (eg. B1)

It needs to loop through the above logic across all open worksheets, dumping the results into a new worksheet.

Once again, thanks for any help I recieve.

Answer 1

This post will be to further elaborate in case anyone has a question.

Answer 2

Here is a start. Your notes suggest that the words will only occur once in each sheet and that there will be a cell 72 rows back. I have included notes on checking these two items, but only sketchily.

Dim c As Range
Dim s As Worksheet
Dim sr As Worksheet ''For results
Dim r1 As Long ''Row counter
Dim i As Long ''Incidence counter
Dim firstAddress As Variant

''New worksheet for results
Set sr = ActiveWorkbook.Worksheets.Add
r1 = 1

''It might be better to use a named workbook
For Each s In ActiveWorkbook.Worksheets
    ''Don't check results sheet
    If s.Name <> sr.Name Then
    ''From: http://msdn.microsoft.com/en-us/library/aa195730(v=office.11).aspx
        With s.UsedRange
            Set c = .Find("THIS IS A TEST", LookIn:=xlValues, LookAt:=xlWhole)
            i = 0
            If Not c Is Nothing Then
                firstAddress = c.Address
                sr.Cells(r1, 1) = c.Value

                If c.Row - 72 > 0 Then
                    sr.Cells(r1, 2) = s.Cells(c.Row - 72, c.Column)
                Else
                    sr.Cells(r1, 2) = "Error"
                End If

                i = 1
                r1 = r1 + 1

                Do
                    i = i + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
    End If
    Debug.Print s.Name & " found: " & i
Next