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

Question

我有以下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

要分解这段代码的作用:

1)设置应搜索的第一张纸和应附加结果的第二张纸(输出纸).

2)在第一列中搜索某个字符串"NAME:",找到后取第二列中的值,将其放在输出表中,然后查找"出生日期:".找到"DATE OF BIRTH:"后,将其放在输出表中"NAME:"的值旁边.

3)重复,直到没有更多条目.

我确定这是一个非常简单的修改,但我想做的是检查某个字符串是否存在,如果它确实直接获取条目,然后继续搜索下一个字符串和相关条目就像代码已经存在.

任何人都可以指出我需要改变才能做到这一点(最好是为什么)？

此外,在将结果存入单张表格的同时,我如何能够将此代码扩展为在多张纸上运行？我是否需要设置在工作表上运行的范围w_1 .... w_(n-1)(输出表w_n可能在不同的工作簿中)？

删除代码中的行继续:

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

更新:只是为了确保我们都在同一页上关于输出的样子.假设我们正在搜索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
.
.
.

Answer 1

谁能指出我需要改变什么才能做到这一点（最好是为什么）？

基本上你需要改变组成的部分NameValue。

最初，您将第一个匹配项旁边的值设为as，现在您想要第一个匹配项下方的w1.Range("B" & i)值，即。w1.Range("A" & i + 1)

原来是：

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

现在你需要这样的东西：

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

此外，我如何能够扩展此代码以在多张纸上运行，同时将结果存储在单张纸中？（输出表 w_n 可能位于不同的工作簿中）？

为了实现这一点，您可以创建一个数组Sheets，并让代码为每个Sheet数组运行。请注意，该数组可能包含 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")

完整的代码可能如下所示（使用您提供的数据进行测试）。

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

注意：我Do-Until用For-Next循环替换了循环，因为如果第一列中不存在字符串“DATE OF BIRTH：”，则Do-Until可能会导致错误。Stack-Overflow :-)不过，我试图保留您原来的代码结构，以便您仍然理解它。HTH。