Excel VBA搜索列中的单词并将该单词下面的行复制到新的工作簿中

Question

我试图运行宏以打开工作簿，搜索单​​词Apples，然后将单词下面的第一行复制到单词上一本新的工作手册。一切都在列A中，单词“苹果”出现在多行上。此代码当前将下一行的Apple &这个词移到另一个表单上。我希望它移动到另一个工作簿，并采取下面的行。由于某种原因，它还在最后抓取了2条不需要的线。我一直在摆弄它，但不知道该从哪里出发。

Sub Apples() 

    Date1 = Range("B3").Value 

    ChDir "C:\Users\Name\Desktop\" & Date1 
    Workbooks.OpenText Filename:= _ 
     "C:\Users\Name\Desktop\" & Date1 & "\File" & Left(Date1, 4), Origin:= _ 
     437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ 
     ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _ 
     , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _ 
     TrailingMinusNumbers:=True 

    Windows("Apples" & Left(Date1, 4)).Activate 
    Sheets.Add After:=Sheets(Sheets.Count) 

    Const fWhat As String = "Apples" 
    Dim R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range, i As Long, delAdr As String 
    With Sheets("Apples" & Left(Date1, 4)) 
    Set R = .Range("A:A").Find(fWhat, [A1], xlFormulas, xlPart, , , False) 
    If Not R Is Nothing Then 
     fAdr = R.Address 
     Set cutRng = R.Offset(0, 0).Resize(4, .UsedRange.Columns.Count) 
     Do 
      Set R = .Range("A:A").FindNext(R) 
      If R Is Nothing Then Exit Do 
      If R.Address = fAdr Then Exit Do 
      Set cutRng = Union(cutRng, R.Offset(0, 0).Resize(4, .UsedRange.Columns.Count)) 
     Loop 
    End If 
    If Not cutRng Is Nothing Then 
     delAdr = cutRng.Address 
     nR = 1 
     For Each Ar In cutRng.Areas 
      Ar.Cut Destination:=Sheets(.Index + 1).Range("A" & nR) 
      nR = Sheets(.Index + 1).Range("A" & Rows.Count).End(xlUp).Row - 1 
     Next Ar 
     .Range(delAdr).Delete shift:=xlUp 
    End If 
End With 

End Sub 

Answer 1

编辑：更正后的代码，每次获取两行;并按照遇到的情况进行复制，而不是等到结束。

以下是您的代码的修改版本。它会打开包含“数据”的工作簿，然后创建一个新的工作簿（如果找到现有名称，则不需要管理），然后使用搜索词加上下一行复制该行。你指出它只需要复制它找到的第一个。

Option Explicit 

Sub Apples() 
Dim wbThis  As Workbook 
Dim wbData  As Workbook 
Dim wbNew  As Workbook 
Dim ws   As Worksheet 
Dim Date1  As String 
Dim strPath  As String 
Const fWhat  As String = "Apples" 
Dim rngR  As Range, copyRng As Range, rngA As Range 
Dim strAdr  As String 
Dim lNextRow As Long, i As Long 
Dim bFound  As Boolean 
Dim rngFirst  As Range 

    Date1 = Range("B3").value 

    strPath = "C:\Users\Name\Desktop\" 
    strPath = "C:\temp\"     ' *** DELETE THIS LINE 

    ChDir strPath & Date1 

    ' Open Workbook which has the data 
    Set wbData = Workbooks.Open(Filename:=strPath & Date1 & "\File" & Left(Date1, 4)) 

    ' Make sure we have the desired Worksheet Name 
    bFound = False 
    For Each ws In wbData.Worksheets 
     If ws.Name = "Apples" & Left(Date1, 4) Then 
      bFound = True 
      Exit For 
     End If 
    Next ws 
    If bFound = False Then 
     MsgBox "Workbook '" & strPath & Date1 & "\File" & Left(Date1, 4) & _ 
      "' does not contain the expected sheet named '" & "Apples" & Left(Date1, 4) & "'." & vbCrLf & vbCrLf & _ 
      "Please correct and start over.", vbOKOnly + vbCritical, "Missing Sheet" 
     wbData.Close 
     GoTo WrapUp 
    End If 

    ' Create New workbook 
    Set wbNew = Workbooks.Add 
    Application.DisplayAlerts = False 
    wbNew.SaveAs Filename:=strPath & "Book123.xlsx" 
    Application.DisplayAlerts = True 

    lNextRow = 0 
    Debug.Print "--------------------" 
    With wbData.Sheets("Apples" & Left(Date1, 4)) 
     Set rngR = .Range("A:A").Find(fWhat, [A1], xlFormulas, xlPart, , , False) 

     If Not rngR Is Nothing Then 
      Set rngFirst = rngR 
      Debug.Print "First: " & rngR.Address 
      lNextRow = 1 
      If Not rngR Is Nothing Then 
       strAdr = rngR.Address 
       Set copyRng = rngR.Offset(0, 0).Resize(2, .UsedRange.Columns.Count) 
       Debug.Print "Copy: " & copyRng.Address 
       copyRng.Copy Destination:=wbNew.Sheets("Sheet1").Range("A" & lNextRow) 
       lNextRow = lNextRow + 2 

       Do 
        Set rngR = .Range("A:A").FindNext(rngR) 
        If rngR Is Nothing Then Exit Do 
        Debug.Print "Next : " & rngR.Address 

        If rngR.Address = strAdr Then Exit Do 
        Set copyRng = rngR.Offset(0, 0).Resize(2, .UsedRange.Columns.Count) 
        Debug.Print "Copy: " & copyRng.Address 
        copyRng.Copy Destination:=wbNew.Sheets("Sheet1").Range("A" & lNextRow) 
        lNextRow = lNextRow + 2 
        'Debug.Print "Combo Before: " & copyRng.Address 
        'Set copyRng = Union(copyRng, rngR.Offset(0, 0).Resize(2, .UsedRange.Columns.Count)) 
        'Set copyRng = Union(copyRng, rngR.Offset(0, 0).Resize(2, .UsedRange.Columns.Count)) 
        'Debug.Print "Combo After : " & copyRng.Address 
       Loop 
      End If 
     Else 
      MsgBox " not Found" 
      Exit Sub 
     End If 
    End With 

    wbData.Close 
    wbNew.Close 

WrapUp: 
    ' Close it down... 
End Sub