Modifying VBA copy and paste code to search down rather than across

Question

I have the following VBA code:

Sub test():

Dim NameValue As String, w1 As Worksheet, w2 As Worksheet

Dim i As Long, j As Long, k As Long, c As Long

Set w1 = Sheets("Sheet2"): Set w2 = Sheets("Sheet3")

GetNameValue: For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).row
        If w1.Range("A" & i) = "NAME:" Then
        If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
        j = i + 1: Do Until w1.Range("A" & j) = "DATE OF BIRTH:": j = j + 1: Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
        c = c + 1: End If
GetNext: Next i: NameValue = NameValue & " "
                    For k = 1 To c
i = InStr(1, NameValue, "|"): j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1): w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
        NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
                    Next k
End Sub

To break down what this code does:

1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.

2) Search the first column for a certain string "NAME:" and once found take the value in the second column, place it in the output sheet go look for "DATE OF BIRTH:". Once "DATE OF BIRTH:" is found put it beside the value for "NAME:" in the output sheet.

3) Repeat until there are no more entries.

I'm sure this is a very simple modification, but what I'd like to do is check whether a certain string exists, if it does grab the entry directly BELOW it, and then continue searching for the next string and associated entry just like the code does already.

Can anyone point me to what I would need to change in order to do this (and preferably why)?

In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? Do I need to set up a range running over the worksheets w_1....w_(n-1) (with output sheet w_n possibly in a different workbook)?

Removed Line continuations in code:

Sub test()

Dim NameValue As String, w1 As Worksheet, w2 As Worksheet

Dim i As Long, j As Long, k As Long, c As Long

Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")

GetNameValue:
    For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
        If w1.Range("A" & i) = "NAME:" Then
            If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
            j = i + 1
            Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
                j = j + 1
            Loop
            NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
            c = c + 1
        End If
GetNext:
    Next i
    NameValue = NameValue & " "
    For k = 1 To c
        i = InStr(1, NameValue, "|")
        j = InStr(i, NameValue, " ")
        w2.Range("A" & k) = Left(NameValue, i - 1)
        w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
        NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
    Next k

End Sub

UPDATE: Just to make sure we're all on the same page about what the output would look like. Suppose we are searching for the entry below A and the entry beside C:

INPUT

A 1
B 
y 3 
z 4
t 
d 
s 7
C 8
A 1
Z 
y 3 
z 4
t 
d 
s 7
C 12


OUTPUT

B 8
Z  12
.
.
.

Answer 1

Assuming I understand your desire correctly, you can use the .Offset method with your current range to get to the cell below it. You would need to add a dim, so here's my stab at what you're trying to accomplish:

Sub test()

Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
'new local variable
Dim newValue as string

Dim i As Long, j As Long, k As Long, c As Long

Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")

GetNameValue:
    For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
        'assuming your string is in column A
        If w1.Range("A" & i) = "FIND ME" Then
            newValue = w1.Range("A" & i).Offset(1,0).Value
        End If
        If w1.Range("A" & i) = "NAME:" Then
            If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
            j = i + 1
            Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
                j = j + 1
            Loop
            NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
            c = c + 1
        End If
GetNext:
    Next i
    NameValue = NameValue & " "
    For k = 1 To c
        i = InStr(1, NameValue, "|")
        j = InStr(i, NameValue, " ")
        w2.Range("A" & k) = Left(NameValue, i - 1)
        w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
        NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
    Next k

End Sub

Then you could do anything you desired with the newValue string, including putting it in w2 like so: w2.Range("D1").value = newValue

UPDATED ANSWER

I am now 89% sure I know what you are trying to accomplish :) thanks for your clarifying example.

To search a range for your search string, you need to set up a range you are looking in:

dim searchRange as range
dim w1,w2 as worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
set searchRange = w1.Range("A" & Rows.Count).End(xlUp).Row

Then you search the searchRange for both of your search strings (which I'm saying are "A" for the first and "C" for the second). As long as both strings are found in the searchRange, it will create a new Dictionary entry for the two values, having the value below "A" as the key and the value beside "C" as the item.

dim rng as range
dim valueBelowFirstSearch as string
dim resultsDictionary as object
dim i as integer
dim c, d as range
dim cAddress, dAddress as string
set resultsDictionary = CreateObject("scripting.dictionary")

with searchRange
    set c = .Find("A", lookin:=xlValues)
    set d = .Find("C", lookin:=xlValues)
    if not c Is Nothing and not d Is Nothing then 
        cAddress = c.address
        dAddress = d.address
        resultsDictionary.add Key:=c.offset(1,0).value, Item:=d.value
        Do
            set c = .FindNext(c)
            set d = .FindNext(d)
        Loop While not c is nothing and not d is nothing and c.address <> cAddress and d.address <> dAddress
    end if
end with

Now that we have all of the results in the resultsDictionary, we can now output the values into another place, which I'm choosing to be w2.

dim outRange as range
dim item as variant
set outRange = w2.Range("A1")

for each item in resultsDictionary
    outRange.Value = item.key
    set outRange = outRange.Offset(0,1)
    outRange.Value = item.item
    set outRange = outRange.Offset(1,-1)
next item

Answer 2

Can anyone point me to what I would need to change in order to do this (and preferably why)?

Basically you need to change the parts of which NameValue is composed.

Originally you took the value beside the first match as w1.Range("B" & i) and now you want the value below the first match, which is w1.Range("A" & i + 1).

---

Originally it was:

Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))

---

Now you need something like this:

Trim(NameValue & " " & w1.Range("A" & i + 1) & "|" & w1.Range("B" & j))

---

In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? (with output sheet w_n possibly in a different workbook)?

To achieve that you can e.g. create an array of Sheets and let the code run for each Sheet of this array. Note that the array might contain 1-N Sheets.

---

' Set array of sheets for just one sheet
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1"))

---

' Set array of sheets for more sheets, e.g. "Sheet1" and "Sheet2" and "Sheet3"
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2", "Sheet3"))

---

' Finally set the second sheet where the results should be appended 
' to sheet in the same workbook as the searched sheets
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeBook.xlsx").Worksheets("ResultSheet")

---

' Or set the second sheet where the results should be appended to sheet 
' in a different workbook then the searched sheets belong to
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")

---

The complete code might look like this (tested with data you provided).

Option Explicit

Public Sub main()
    ' String to search below of it
    Dim string1 As String
    string1 = "A"

    ' String to search beside of it
    Dim string2 As String
    string2 = "C"

    ' Set the sheets that should be searched
    Dim searchedSheets As Sheets
    Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2"))

    ' Set the second sheet (outputSheet sheet) that the results should be 
    ' appended to external sheet in different book
    Dim outputSheet As Worksheet
    Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")

    SearchFor string1, string2, searchedSheets, outputSheet
End Sub

Public Sub SearchFor( _
    string1 As String, _
    string2 As String, _
    searchedSheets As Sheets, _
    output As Worksheet)

    Dim searched As Worksheet
    Dim NameValue As String
    Dim below As String
    Dim beside As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim c As Long
    Dim rowsCount As Long

    For Each searched In searchedSheets

        rowsCount = searched.Range("A" & Rows.Count).End(xlUp).Row
        For i = 1 To rowsCount

            ' Search the first column for a 'string1'
            If searched.Range("A" & i) = string1 Then

                ' once 'string1' was found grab the entry directly below it
                below = searched.Range("A" & i + 1)

                If InStr(1, NameValue, below) Then
                    ' skip this 'below' result because it was found before
                    GoTo GetNext
                End If

                ' Search the first column for a 'string2' starting at the       
                ' position where 'below' was found
                For j = i + 1 To rowsCount
                    If searched.Range("A" & j) = string2 Then
                        ' once 'string2' was found grab the entry directly 
                        ' beside it
                        beside = searched.Range("B" & j)
                        Exit For
                    End If
                Next j

                ' Append 'below' and 'beside' to the result and count the 
                ' number of metches
                NameValue = Trim(NameValue & " " & below & "|" & beside)
                c = c + 1

            End If
GetNext:
        Next i
    Next searched

    ' Write the output
    NameValue = NameValue & " "
    For k = 1 To c
        i = InStr(1, NameValue, "|")
        j = InStr(i, NameValue, " ")
        output.Range("A" & k) = Left(NameValue, i - 1)
        output.Range("B" & k) = Mid(NameValue, i + 1, j - i)
        NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
    Next k
End Sub

Note: I replaced the Do-Until loop with For-Next loop because the Do-Until might cause a Stack-Overflow :-) error if the string "DATE OF BIRTH:" does not exist in the first column. However I have tryied to keep your originall code structure so you still understand it. HTH.