Change VBA copy and paste code to search down, not through

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 this code:

1) Define the first sheet to be found and the second sheet (output sheet) to which the results should be added.

2) Find the first column for the specific row "NAME:" and once we find the value in the second column, put it in the output sheet, look for "DATE ​​OF BIRTH:". After "DATE ​​OF BIRTH:" is found, put it next to "NAME:" in the output sheet.

3) Repeat until there are no more entries.

I am sure that this is a very simple modification, but what I would like to do is check if a certain line exists if it captures the record directly BELOW it, and then continue to search for the next line and the record associated with it, as well as the code.

Can someone point me to what I will need to change in order to do this (and, preferably, why)?

In addition, how can I extend this code to run multiple sheets when submitting results on one sheet? Do I need to adjust the range that goes through the sheets w_1 .... w_ (n-1) (with the output sheet w_n, possibly in another book)?

Remote 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 will look like. Suppose we are looking for the entry below A and the entry next to C:

 INPUT A 1 B y 3 z 4 tds 7 C 8 A 1 Z y 3 z 4 tds 7 C 12 OUTPUT B 8 Z 12 . . . 

Answer 1

Can someone tell me what I need to change to do this? (and, preferably, why)?

Basically you need to change the parts that NameValue consists of.

Initially, you took the value next to the first match as w1.Range("B" & i) , and now you need a value below the first match, which is equal to 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))

---

Also, how can I extend this code to run multiple sheets when submitting results on one sheet? (with output sheet w_n, possibly in another book)?

To achieve this, you can, for example, create an array of Sheets and let the code run for each Sheet this array. Note that the array may 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, eg "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 full code may look like this (checked with the 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 the For-Next loop, because Do-Until can cause a Stack-Overflow :-) error if the string "DATE ​​OF BIRTH:" does not exist in the first column. However, I tried to preserve the original code structure so that you still understand this. NTN.

Answer 2

Assuming I understand your desire correctly, you can use the .Offset method with your current range to go to the cell below. You will need to add dullness, so here I get what you are 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 whatever you want with the newValue string, including putting it in w2 as follows: w2.Range("D1").value = newValue

UPDATED RESPONSE

Now I am sure that 89% know what you are trying to do :) thanks for the clarifying example.

To find the range for the search bar, you need to configure the range in which you look:

 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 do a searchRange for both search strings (I say “A” for the first and “C” for the second). As long as both lines are found in searchRange , it will create a new dictionary entry for two values ​​that have a value below "A" as the key and the value next to "C" as the element.

 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 the results in the resultsDictionary , we can now output the values ​​to another location that I select 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 3

Assuming you want to find one value ( Name: , continue searching to find the second ( Date Of Birth: ... Finally, you want to move this pair of data to another worksheet.

To achieve this, I suggest using the Dictionary object to get only individual values. I strongly discourage using string concatenation as you pointed out 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 

Output Example:

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