修改VBA复制和粘贴代码来search而不是跨search
我有以下的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）设置应该search的第一张纸和第二张纸（输出纸），结果应该附加到。
2）在第一列中search某个string“NAME：”，一旦find第二列中的值，将其放在输出表中去寻找“DATE OF BIRTH：”。 发现“出生date：”后，将其放在输出表中“NAME：”的值旁边。
3）重复，直到没有更多的条目。
我确定这是一个非常简单的修改，但是我想要做的是检查某个string是否存在，如果它直接在下面获取条目，然后继续search下一个string和关联条目，就像该代码已经。
任何人都可以指出，为了做到这一点，我需要改变（最好是为什么）？
另外，如何能够将这些代码扩展到多个表单中，并将结果存放在一张表中？ 是否需要设置运行在工作表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
更新：只是为了确保我们都在同一页上的输出是什么样子。 假设我们正在searchA以下的条目和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 . . .
任何人都可以指出，为了做到这一点，我需要改变（最好是为什么）？
基本上你需要改变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可能在不同的工作簿中）？
为了达到这个目的，你可以例如创build一个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, 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")
完整的代码可能如下所示（使用您提供的数据进行testing）。
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
注意：如果string“DATE OF BIRTH：”在第一列中不存在，则我将Do-Until循环replaceFor-Next循环，因为Do-Until可能会导致Stack-Overflow :-)错误。 然而，我试图保持你的原始代码结构，所以你仍然理解它。 HTH。
假设我正确地理解了你的愿望，你可以使用当前范围的.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
然后你可以用newValuestring做任何你想做的事情，包括把它放在w2中，如下所示： w2.Range("D1").value = newValue
更新的答案
我现在89％确定我知道你在做什么:)谢谢你的澄清的例子。
要searchsearchstring的范围，您需要设置您正在查找的范围：
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
然后你searchsearchRangesearchstring（我说的是“A”的第一个和“C”的第二个）。 只要在searchRange中find两个string，它就会为这两个值创build一个新的字典条目，其值低于“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有了所有的结果，现在我们可以将这些值输出到另一个地方，我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
假设您想要查找一个值（ Name: ：），然后继续search，直到find第二个（ Date Of Birth: ）…最后，您要将这些数据对移动到另一个工作表中。
为了达到这个目的，我build议使用Dictionary对象来获得唯一的值。 我强烈build议不要像您在代码中提供的那样使用string连接。
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