Excel VBA在列中搜索一个单词，并将单词下面的行复制到新的工作簿上 [英] Excel VBA search for a word in a column and copy the row below the word onto a new workbook

问题描述

我正在尝试运行一个宏来打开工作簿，搜索苹果一词，然后将单词下面的第一行复制到新的工作簿上。一切都在A列，Apples一词出现在多行上。该代码目前采用Apple&下面的行将其移动到另一张纸上。我想要它移动到另一个工作簿，并采取下面的行。由于某种原因，它也会在最后抓住2条不需要的线。我一直在迷惑，但不知道从哪里去。

I am trying to run a macro to open a workbook, search for the word Apples and then copy the first row below the word onto a new workbook. Everything is in column A and the word "Apples" comes up on multiple rows. This code currently takes the word Apple & the row below and moves it onto another sheet. I want it to move to another workbook and take just the row below. For some reason it also grabs 2 unwanted lines at the end. I been fiddling with it but am not sure where to go from here.

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

推荐答案

编辑：纠正代码每次得到两行;并复制一次遇到而不是等待直到结束。

Corrected code to get two rows each time; and to copy as encountered rather than waiting until end.

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

The following is a modified version of your code. It opens the workbook that has your 'data', then creates a new workbook (no provision for managing if existing name found), then copies the row with the search term plus the next row. You indicated it only needs to copy the FIRST it finds.

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在列中搜索一个单词，并将单词下面的行复制到新的工作簿上的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！