Question

我是新人，而且我已经尝试了几天这个宏。我想要做的是通过列A搜索单词＆＃34; REPORT＆＃34 ;;然后剪切并粘贴其间的所有行＆＃34; report＆＃34; （包括空白行）到新表。它有点工作，但它不会停止，因为它会继续寻找＆＃34; REPORT＆＃34;。这是我的数据的样子。感谢。

表格

         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|

代码：

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

确保您将第1行作为标题行，然后您可以利用AutoFilter()和SpecialCells()方法以及Areas()对象的Range属性，如下所示：

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

在两个值之间剪切行并将其粘贴到新工作表

1 个答案: