修改VBA复制和粘贴代码以搜索到下而不是跨

I have the following VBA code:

我有以下VBA代码:

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.

1)设置第一个要搜索的表和第二个要附加结果的表(输出表)。

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.

2)搜索某字符串的第一列“NAME:”，一旦找到第二列的值，将其放在输出表中，查找“出生日期:”。一旦找到“出生日期:”，将其放在输出表中“名称:”的值旁边。

3) Repeat until there are no more entries.

3)重复，直到没有其他条目。

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)?

此外，我如何能够扩展这段代码，以便在将结果存储在单个表中同时运行多个表?我需要在工作表设置一系列运行w_1 .... w_(n - 1)与输出(表w_n可能在不同的工作簿)?

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:

更新:确保我们在输出的内容上是一致的。假设我们搜索A下面的条目和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
.
.
.

3 个解决方案

#1

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.

基本上，您需要更改NameValue的组成部分。

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

最初，你在第一个匹配项下取值为w1。Range("B" & i)现在你想要在第一个匹配项下的值，即w1。范围(A和i + 1)。

---

Originally it was:

原来它是:

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

修剪(NameValue &“”和w1。范围(“B”和i)和“|”和w1。范围(“B”& j))

---

Now you need something like this:

现在你需要这样的东西:

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

修剪(NameValue &“”和w1。范围(A和i + 1)和|和w1。范围(“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)?

此外，我如何能够扩展这段代码，以便在将结果存储在单个表中同时运行多个表?(输出表w_n可能在不同的工作簿中)?

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.

为了实现这一点，您可以创建一个表数组，并让该数组的每个表运行代码。注意，该数组可能包含1-N个表。

---

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

注意:我将Do-Until循环替换为For-Next循环，因为如果字符串“出生日期:”在第一列中不存在，那么Do-Until可能导致堆栈溢出:-)错误。但是，我已经尝试保持您的原始代码结构，以便您仍然理解它。HTH。

#2

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:

假设我正确地理解了您的要求，您可以使用. offset方法来获取当前范围的单元格。你需要添加一个dim，所以我建议你完成以下任务:

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

然后您可以使用newValue字符串做任何您想做的事情，包括将它放在w2中，如so: w2. range(“D1”)。值= newValue

UPDATED ANSWER

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

我现在有89%的人相信我知道你想要达到的目标:)谢谢你的澄清例子。

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.

然后在searchRange中搜索两个搜索字符串(第一个是A，第二个是C)。只要在searchRange中找到这两个字符串，它就会为这两个值创建一个新的字典条目，以“a”下面的值作为键，以“C”旁边的值作为项。

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.

现在我们已经在resultsDictionary中获得了所有的结果，现在我们可以将这些值输出到另一个位置，我将选择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

#3

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.

假设您希望找到一个值(Name:)，然后继续搜索，直到找到第二个值(出生日期:)……最后，您需要将这两个数据移动到另一个工作表中。

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!

为了实现这一点，我建议使用Dictionary对象只获取不同的值。我强烈建议不要像您在代码中提供的那样使用字符串连接!

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