vba - 修改 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:”，一旦找到，就取第二列中的值，将其放入输出表中，然后查找“出生日期:”。一旦找到“出生日期:”，请将其放在输出表中“姓名:”值的旁边。

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

假设我正确理解您的愿望，您可以使用 .Offset 方法和当前范围来访问其下方的单元格。您需要添加一个暗淡的颜色，所以这是我对您想要实现的目标的尝试:

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

然后您可以使用 newValue 字符串执行任何您想要的操作，包括将其放入 w2 中，如下所示:w2.Range("D1").value = newValue

更新答案

我现在 89% 确定我知道您想要实现的目标:) 感谢您提供的澄清示例。

要搜索搜索字符串的范围，您需要设置要查找的范围:

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

然后，您在 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

现在我们已经将所有结果存储在 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