logo标签列表

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

vbaexcel
7
我有以下的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:”。一旦找到“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
.
.
.
在回答问题之前，我强烈建议从上面的代码中删除使用:组合的行。 :组合的控制流程行（如For...Next和If...Then）使上述代码难以进行视觉解析... - Dan Wagner
以下是关于此问题的SO意见背景: https://dev59.com/wHM_5IYBdhLWcg3wWRyV - Dan Wagner
@DanWagner 谢谢，我应该澄清一下，我并不是这段代码的主要创作者，我只是在使用它，因为它符合我的需求，但并没有完全理解其中的所有内容。不过我一定会看看那个链接的。 - 114
输入表格长什么样？为什么输出是B 8和B 12？我不明白你的问题... ;( - Maciej Los
@MaciejLos 想象一下，它看起来就像每个单元格都包含一个字母数字或空格的示例，并且继续延伸到1000000行。A和C总是相同的，但在A下面的单元格中的项目会变化。 - 114
显示剩余2条评论
3个回答
4

假设我正确理解了你的要求，您可以使用当前范围的.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

那么你可以用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中找到这两个字符串，它就会为这两个值创建一个新的字典条目，将下面的值作为键，旁边的值作为项。

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
1
谢谢！只是为了明确，“FIND ME”和“NAME:”是在搜索什么？以前只有两个输入，现在有三个（那两个和出生日期）。 - 114
我提出这个问题的原因是，不幸的是，我无法让程序按照预期运行。 - 114
1
谢谢乔治。我的意思是以前我只需输入“姓名”和“出生日期”，第三个值“找到我”的作用是什么？目前我只是为这三个值输入“A”，“A”，“B”（例如）。 - 114
1
我认为我们已经接近了，但是在lookin:xlValues处出现了错误。错误是“编译错误：预期：列表分隔符或)”。一旦修复了这个问题，我应该能够测试它。对于比我最初的代码更清晰的代码，加1。 - 114
1
已修复。现在出现了“下标超出范围”的错误。我已经验证了工作表名称和搜索项的正确性。更新：当错误发生时，没有特定的位置被突出显示，只是简单地出现了消息。 - 114
显示剩余7条评论
3
假设您想找到一个值（Name:），然后继续搜索直到找到第二个值（Date Of Birth:）... 最后，您想将这对数据移动到另一个工作表中。
为了实现这一点，我建议使用字典对象来获取唯一的值。我强烈不建议像您在代码中提供的那样使用字符串拼接！
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

示例输出：

Name    DateOfBirth:
A       1999-01-01
B       1999-01-02
C       1999-01-03
D       1999-01-04
E       1999-01-05
抱歉，它无法运行。当我执行时没有任何错误，但是什么也没有发生。 - 114
你尝试过调试程序（F8）吗？你是否添加了对Microsoft Scripting dll的引用？ - Maciej Los
那很可能就是问题所在，谢谢！我该如何添加引用？另外，只是想澄清一下，我不是想要“姓名：”和“出生日期：”，而是最初我想要这两个标签右侧的值。现在我想要“姓名：”下面的值和（与以前一样）“出生日期：”右侧的值。 - 114
在代码窗格中，转到“工具”->“引用”。该代码完全符合您的要求。请随意根据您的需求进行修改。 - Maciej Los
您IP地址为143.198.54.68，由于运营成本限制，当前对于免费用户的使用频率限制为每个IP每72小时10次对话，如需解除限制，请点击左下角设置图标按钮（手机用户先点击左上角菜单按钮）。 - 114
是的，它是。在调试模式下运行“Test”子程序：将光标放置在“Test”过程内并按F8。 - Maciej Los
3
有人能告诉我我需要更改什么才能做到这一点（最好是为什么）？
基本上，您需要更改组成NameValue的部分。
最初，您将第一个匹配项旁边的值作为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 :-)错误。然而，我已经尝试保持您的原始代码结构，以便您仍然可以理解它。希望对你有所帮助。
是的，我全部复制了。我还做了两个更改： Set searchedSheets = ThisWorkbook.Worksheet("Sheet1") 和 Set outputSheet = ThisWorkbook.Worksheet("TestSheet")。这会有影响吗？ - 114
@114 尝试将代码分解成小部分，开始注释掉 sub-end sub 内的所有代码，并尝试找到错误的原因。您是否使用 编译？ - Daniel Dušek
1
@114 ThisWorkbook.Worksheet 不正确，应该是 ThisWorkbook.Worksheets。 - Daniel Dušek
啊，我想我明白问题所在了，那么我该如何编辑代码，以便我可以选择只搜索一个工作表或多个工作表？ - 114
让我们在聊天中继续这个讨论：http://chat.stackoverflow.com/rooms/81899/discussion-between-dee-and-114。 - Daniel Dušek
显示剩余2条评论
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接