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
.
.
.

Before even getting to the question at hand, I would *highly* recommend removing the `:`-combined lines from the above code. `:`-combined control flow lines (like `For...Next` and `If...Then`) make the above difficult to visually parse... — Dan Wagner, Jun 22 '15 at 21:01
Here's some background on what SO thinks about them too: http://stackoverflow.com/questions/1411711/using-colons-to-put-two-statements-on-the-same-line-in-visual-basic — Dan Wagner, Jun 22 '15 at 21:02
@DanWagner Thanks, I should clarify that I wasn't really the primary creator of this code, I've just been using it since it fit my purpose without fully understanding how everything works. I'll definitely take a look at that link though. — 114, Jun 22 '15 at 21:03
How exactly input sheet looks ? Why the output is B 8 and B 12? I do not understand your issue... ;( — Maciej Los, Jun 24 '15 at 20:32
@MaciejLos The output is B 8 and B 12 (I've changed this to Z 12) because we're first searching for what's in the cell directly below A and then whatever is beside the next cell containing C. The original code looks for A and what's beside A and then C and what's beside C. — 114, Jun 24 '15 at 20:39
The question is still unclear ;( How exactly input sheet looks like? — Maciej Los, Jun 24 '15 at 21:25
@MaciejLos Imagine it looks exactly like that sample where each cell contains one letter number or empty space and continues for 1000000 rows. A and C are always the same, but items one cell below A vary. — 114, Jun 24 '15 at 22:00

deasa · Answer 1 · 2015-06-25T16:39:10.187

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

Thanks! Just to be clear, what is being searched for with "FIND ME" and "NAME:"? Before there were only two inputs and now there are three (those two and DATE OF BIRTH). — 114, Jun 23 '15 at 15:18
The reason I ask is that unfortunately I can't get the program to work as intended. — 114, Jun 23 '15 at 16:06
The way you have written your code, a cell in row A would need to have the exact text "NAME:" for your code to pick it up. My code works the same way, a cell in row A would need to have the exact text "FIND ME" for the `newValue` to be set to the value of the cell below it. — deasa, Jun 23 '15 at 16:46
Thanks George. What I mean is before I would only have to enter NAME: and DATE OF BIRTH: - what role is the third value FIND ME playing? Currently I'm just putting in 'A', 'A', 'B' (for example) for those three values. — 114, Jun 23 '15 at 17:39
I wrote the FIND ME third value in there because that's what I thought you meant when you said "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." The _certain string_ I wrote code to search for was `"FIND ME"` and the **then continue searching for the next string** I took to mean that you wanted this new search before your existing code. — deasa, Jun 23 '15 at 20:05
Thanks, sorry for the confusion! I see where the issue is now. What I'd actually like to do is search for the first string "NAME:" as usual, but, once found, select the cell below it rather than the cell beside it. Then as usual the program would continue and check for the "DATE OF BIRTH:" string and place the value beside it in the new sheet. I'll need to be more careful about my phrasing in the future. — 114, Jun 23 '15 at 20:37
@114 Thanks for the clarification. See my updated answer, hopefully this is much closer to what you actually asked for in the first place! :) — deasa, Jun 25 '15 at 16:25
I think we're getting closer, but I get an error at lookin:xlValues. The error is "Compile error: Expected: list separator or)". Once that's fixed I should be able to test it out. +1 for code that's much clearer than my initial code. — 114, Jun 25 '15 at 16:35
@114 Change `lookin:xlValues` to `lookin:=xlValues`. I'll update my answer as well. — deasa, Jun 25 '15 at 16:37
Fixed. I'm now getting a 'subscript out of range' error. I've verified that the sheet names and search terms are correct. UPDATE: No specific location highlighted when error occurs, message simply comes up. — 114, Jun 25 '15 at 16:50
If you need help fixing the errors, you will need to say where you are getting the error so I can help. — deasa, Jun 25 '15 at 16:54
Let us [continue this discussion in chat](http://chat.stackoverflow.com/rooms/81562/discussion-between-bgeorge-and-114). — deasa, Jun 25 '15 at 17:00

score 3 · Answer 2 · answered Jun 25 '15 at 15:23

Assuming that you want to find one value (Name:), then continue searching till to find the second one (Date Of Birth:)... Finally, you want to move these pair of data into another worksheet.

To achieve that, i'd suggest to use Dictionary object to get only distinct values. I strongly do not recommend to use string concatenation as you provided in your code!

Option Explicit

Sub Test()
Dim src As Worksheet, dst As Worksheet

Set dst = ThisWorkbook.Worksheets("Sheet2")
For Each src In ThisWorkbook.Worksheets
    If src.Name = dst.Name Then GoTo SkipNext
    NamesToList src, dst
SkipNext:
Next

End Sub


'needs reference to MS Scripting Runtime library
Sub NamesToList(ByVal srcWsh As Worksheet, ByVal dstWsh As Worksheet, _
        Optional ByVal SearchFor As String = "NAME:", Optional ByVal ThenNextFor As String = "DATE OF BIRTH:")

Dim dic As Dictionary, i As Long, j As Long, k As Long
Dim sKey As String, sVal As String

On Error GoTo Err_NamesToList

Set dic = New Dictionary

i = 2
j = GetFirstEmpty(srcWsh)
Do While i < j
    If srcWsh.Range("A" & i) = SearchFor Then
        sKey = srcWsh.Range("B" & i)
        If Not dic.Exists(sKey) Then
            Do While srcWsh.Range("A" & i) <> ThenNextFor
                i = i + 1
            Loop
            sVal = srcWsh.Range("B" & i)
            dic.Add sKey, sVal
            k = GetFirstEmpty(dstWsh)
            With dstWsh
                .Range("A" & k) = sKey
                .Range("B" & k) = sVal
            End With
            'sKey = ""
            'sVal = ""
        End If
     End If
SkipNext:
    i = i + 1
Loop

Exit_NamesToList:
    On Error Resume Next
    Set dic = Nothing
    Exit Sub

Err_NamesToList:
    Resume Exit_NamesToList

End Sub


Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
    GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function

Sample output:

Name    DateOfBirth:
A       1999-01-01
B       1999-01-02
C       1999-01-03
D       1999-01-04
E       1999-01-05

Sorry, it doesn't run. It doesn't give any errors when I execute but nothing happens. — 114, Jun 25 '15 at 17:28
Have you tried to debug the programm (F8)? Did you add reference to Microsoft Scripting dll? — Maciej Los, Jun 25 '15 at 18:29
That's likely the issue, thanks! How do I add a reference? Also just to clarify, it's not that I want "Name:" and "Date of Birth:", it's that originally I wanted the values to the right of both of those. Now I want the value below "Name:" and (as before) the value to the right of "Date of Birth:" — 114, Jun 25 '15 at 18:36
In code pane - go to Tools->References. The code does exactly what you want. Feel free to modify it to your needs. — Maciej Los, Jun 25 '15 at 18:38
Is it "Microsoft Scripting Runtime"? If so that was already active. I run into two issues: I have two sheets - "Sheet1" housing the data and "Sheet2" for output. If I set dst to Sheet1 I execute Sub Test() and nothing happens. If I set it to Sheet2 I get a subscript out of range error. — 114, Jun 25 '15 at 18:41
Yes, it is. Run `Test` subroutine in debug mode: place cursor inside `Test` procedure and push F8. — Maciej Los, Jun 25 '15 at 18:43

Daniel Dušek · Accepted Answer · 2015-07-01T09:32:42.040

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.

This looks great, but I'm getting the error `Compile Error: Method or data member not found` on the first line `Sub main()` - have you come across this before? — 114, Jun 29 '15 at 17:45
@114 hmmm that's strange, did you copy the complete code ```End Sub``` inclusive? What is on the line before ```Sub main()```? Try to rename ```main()``` to e.g. ```test()``` ... but hmmm hmmm it is strange :-). — Daniel Dušek, Jun 29 '15 at 18:01
Yep, copied everything. I did make two other changes: `Set searchedSheets = ThisWorkbook.Worksheet("Sheet1")` and `Set outputSheet = ThisWorkbook.Worksheet("TestSheet")`. Could that have an effect? — 114, Jun 29 '15 at 18:44
@114 try to decompose the code into small parts, start to comments out all the code inside of the sub-end sub and try to find the reason for the error. Do you use [Compile](http://www.ehow.com/how_8780902_compile-vba-code.html)? — Daniel Dušek, Jun 29 '15 at 18:49
@114 ```ThisWorkbook.Worksheet``` is not correct, it needs to be ```ThisWorkbook.Worksheets```. — Daniel Dušek, Jun 29 '15 at 18:52
Ah, I think I see what the problem is then, how would I edit the code so that I have the option to choose only one sheet or many sheets to search through? — 114, Jun 29 '15 at 18:59
Let us [continue this discussion in chat](http://chat.stackoverflow.com/rooms/81899/discussion-between-dee-and-114). — Daniel Dušek, Jun 29 '15 at 19:04

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

3 Answers3

UPDATED ANSWER