Question

我正在尝试运行一个宏来打开一个工作簿，搜索单词Apples，然后将该单词下面的第一行复制到一个新工作簿上。一切都在A栏中，“苹果”这个词出现在多行上。此代码目前采用Apple＆amp; amp;下面的行并将其移动到另一张纸上。我希望它移动到另一个工作簿，并采取下面的行。由于某种原因，它最后还会抓取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

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

以下是您的代码的修改版本。它会打开包含您的数据的工作簿，然后创建一个新工作簿（没有用于管理是否找到现有名称），然后使用搜索词加上下一行复制该行。你表示它只需要复制它找到的FIRST。

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

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

1 个答案: