Question

我想循环并提取在列中重复的两个不同单词（例如56050067和56050068）之间的所有行。这段代码使我获得了第一个范围

感谢您的参与

我的桌子是这样的：

56060067 一种乙 C d F 56060068 Ĵ H 一世 ķ 大号 56043556 Ť ÿ Ĵ ķ ñ 56060067 Ø P 问 w ^ X 56060068 。。。。。。。代码：

Sub copy()

    Dim rownum As Long
    Dim colnum As Long
    Dim startrow As Long
    Dim endrow As Long
    Dim lastrow As Long
    Dim s As Range
    Dim e As Range
    rownum = 1
    colnum = 1

    lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row

    With Sheets("Sheet1") 'or this can be any other sheet where you search

        Set r = .Range("B:B").Find("56050067")
        If Not r Is Nothing Then

            Set e = .Range("B:B").Find("56050068", r).Offset(-1)
            If Not e Is Nothing Then
                .Range(r, e).EntireRow.copy Sheets("Sheet2").Range("A1") 'or to whatever sheet
            End If

        End If

    End With

End Sub

Answer 1

所以我让它循环直到达到B的范围结尾，请记住在宏中也就是我修改过的那个，它正在专门搜索这些数字。

 Sub copy()

    Dim rownum As Long
    Dim colnum As Long
    Dim startrow As Long
    Dim endrow As Long
    Dim lastrow As Long
    Dim xLastrow As Long
    Dim s As Range
    Dim e As Range
    rownum = 1
    colnum = 1

    lastrow = Worksheets("Sheet1").Range("B65536").End(xlUp).Row
    Set s = ThisWorkbook.Worksheets("Sheet1").Range("B1")
LoopHere:
    xLastrow = Worksheets("Sheet2").Range("B65536").End(xlUp).Row
    Set e = ThisWorkbook.Worksheets("Sheet1").Range("B" & lastrow)

    With Sheets("Sheet1") 'or this can be any other sheet where you search

        Set s = .Range(s, e).Find("56050067")
        If Not s Is Nothing Then

            Set e = .Range(s, e).Find("56050068", s)
            If Not e Is Nothing Then
                .Range(s, e).EntireRow.copy Sheets("Sheet2").Range("A" & xLastrow) 'or to whatever sheet
            End If

        End If

    End With

    Set s = e.Offset(1).Resize(lastrow)

    If e.Row > lastrow Or e.Row = lastrow Then
    Else
    GoTo LoopHere
    End If



End Sub

Answer 2

您可以过滤想要的数字“对”，然后遍历过滤后的单元格“对”

Sub copy()    
    Dim iArea As Long
    Dim found As Range, area As Range

    With Sheets("Sheet1") 'reference sheet1
        With .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)) ' reference referenced sheet column B cells from row 1 (header) down to last not empty one
            .AutoFilter field:=1, Criteria1:=Array("56060067", "56060068"), Operator:=xlFilterValues ' filter referenced range with wanted numbers pair
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set found = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' if any filtered cell other then header then store it in 'found' range to
        End With
        .AutoFilterMode = False 'remove filter
        If Not found Is Nothing Then ' if wanted pairs found
            With found ' reference found cells
                For iArea = 1 To .Areas.Count Step 2 ' loop through found range "pairs" of cells
                    .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea + 1).Offset(-1)).EntireRow.copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1) ' copy rows in between current "pair" and paste them to sheet2 from its column A first empty cell cells
                Next
            End With
        End If
    End With
End Sub

在第一个值可变的两个值之间复制所有行

2 个答案: