Question

我需要在找到特定单词后复制未知数量的行，直到下一个单词出现。

这是数据库：

Counterparty | 721 | 721 Healthcare | CCY | Invoice amount
----------------------------------------------------------

12/03/14     |    12/10/14  |      081673 |        USD |     1000

12/22/14     |    12/22/14 |      081954  |       USD   |   999

Counterparty | 722 | 722 Healthcare | CCY | Invoice Amount
----------------------------------------------------------

12/22/14     |    12/22/14 |      081954  |       USD   |   999
12/22/14     |    12/22/14 |      081954  |       USD   |   999

这种情况继续发生，行数每月都有所不同。我只需要找到一家公司（由721代表）。我需要的是从标题中复制：Counterparty，721,721 Healthcare，CCY，Invoice Amount。随后是它下面的数据，直到它遇到另一家公司。基本上只从721和所有信息复制，直到达到722并将其粘贴到新工作表上。

Answer 1

这就是我的想法。我不知道是否有一个简单的方法，但它仍然有效。可能会有一些不必要的项目，所以请检查。

宏观的想法是搜索“＃34; Counterparty＆＃34;通过列并相应地识别范围以进行复制。然后，它将范围复制并粘贴到具有动态名称的新工作表。我希望它有所帮助。

Dim SearchItem As String
Dim SearchResult As Range
Dim LastRowWS As Long
Dim SWS As Worksheet
Dim CopyRow As Long
Dim PasteSeq As Integer
Dim CopyStart As Long



Set SWS = Sheets("Search")
SearchItem = "*Counterparty*"
PasteSeq = 0
CopyStart = 1

LastRowWS = Range("A1").End(xlDown).Row

For i = 1 To LastRowWS
    With SWS.Range("A:A")
        'dynamic range to find next item
        Set SearchResult = .Find(What:=SearchItem, _
        After:=Range("A" & i), _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False)
        If Not SearchResult Is Nothing Then
                PasteSeq = PasteSeq + 1 'For new sheetname
                On Error GoTo LastRow 'For the last part
                CopyRow = SearchResult.Offset(-1, 0).Row
                Rows(CopyStart & ":" & CopyRow).Copy
                Sheets.Add.Name = "PasteSheet" & PasteSeq
                Sheets("PasteSheet" & PasteSeq).Range("A1").PasteSpecial xlPasteAll
                Sheets("Search").Select
                CopyStart = SearchResult.Row
                i = CopyRow 'SearchResult.Row
        End If
    End With
Next

LastRow:
Rows(CopyRow + 1 & ":" & LastRowWS).Copy
Sheets.Add.Name = "PasteSheet" & PasteSeq
Sheets("PasteSheet" & PasteSeq).Range("A1").PasteSpecial xlPasteAll
Sheets("Search").Select

从单词复制x行并在单击另一个单词时停止

1 个答案: