schneiden Sie Zeilen zwischen 2 Werte und fügen Sie es auf einem neuen Blatt

Question

Ich bin neu und ich habe versucht, an diesem Makro für ein paar Tage jetzt zu arbeiten. Was ich versuche, ist, durch Spalte A nach dem Wort "REPORT" zu suchen; Dann schneide und füge alle Zeilen zwischen "Bericht" (einschließlich Leerzeichen) in ein neues Blatt ein. Es funktioniert irgendwie, aber es würde nicht aufhören, weil es weiterhin nach dem "REPORT" Ausschau halten würde. So sehen meine Daten aus. Vielen Dank.

Tabelle:

  A 
    --------------- 
1| REPORT 
2| SOLICITOR_ID 
3| ISSUER: 
4| CUSIP: 
5| RECORD_DATE: 
6| TOTAL 
7| 
8| 
9| 
10| 
11| 
12| REPORT 
13| SOLICITOR_ID 
14| ISSUER: 
15| CUSIP: 
16| RECORD_DATE: 
17| 
18| 
19| 
20| 
21| 
22| REPORT 
23| SOLICITOR_ID 
24| ISSUER: 
25| CUSIP: 
26| RECORD_DATE: 
27| 
28| 

Code:

Sub BRGFileCleanup() 

Dim rownum As Long 
Dim colnum As Long 
Dim startrow As Long 
Dim endrow As Long 
Dim lastrow As Long 

Do 
    rownum = 1 
    colnum = 1 
    lastrow = Worksheets("BRG_FILE").Range("A65536").End(xlUp).Row 

    With ActiveWorkbook.Worksheets("BRG_FILE").Range("A1:A" & lastrow) 

    For rownum = 1 To lastrow 

Do 
    If .Cells(rownum, 1).Value = "REPORT" Then 
     startrow = rownum 

    End If 

    rownum = rownum + 1 

If (rownum > lastrow) Then Exit For 

Loop Until .Cells(rownum, 1).Value = "REPORT" 
    endrow = rownum - 1 
    rownum = rownum + 1 

    Worksheets("BRG_FILE").Range(startrow & ":" & endrow).Cut 

    Sheets.Add After:=Sheets(Sheets.Count) 

    Range("A1").Select 
    ActiveSheet.Paste 
    Worksheets("BRG_FILE").Range(startrow & ":" & endrow).Delete 

Next rownum 
End With 

Loop Until ActiveSheet.Range("A1").Value = "" 

End Sub 

Answer 1

nur sicher sein, Sie haben die Zeile 1 als Kopfzeile und dann können Sie AutoFilter() und SpecialCells() Methoden nutzen und Areas() Eigentum Range Objekt wie folgt:

Option Explicit 

Sub main() 
    Dim iArea As Long 
    Dim filteredRng As Range 

    With Worksheets("BRG_FILE") 
     With .Range("A1", .Cells(.Rows.count, 1).End(xlUp).Offset(1)) 
      .Cells(.Rows.count) = "REPORT" 
      .AutoFilter field:=1, Criteria1:="REPORT" 
      If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then 
       Set filteredRng = Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow) 
      End If 
      .Cells(.Rows.count).ClearContents 
     End With 
     .AutoFilterMode = False 
    End With 

    If Not filteredRng Is Nothing Then 
     With filteredRng 
      For iArea = 1 To .Areas.count - 1 
       Sheets.Add After:=Sheets(Sheets.count) 
       .Parent.Range(.Areas(iArea), .Areas(iArea + 1).Offset(-1)).Cut 
       ActiveSheet.Paste 
      Next 
     End With 
    End If 
End Sub