Excel VBA：根据可变数量的电话号码提取可变数量的行

Question

我们希望使用 Excel VBA/宏自动执行此过程，因为我们每周处理 2 到 10 个电子表格。 我们希望从一组可变的电话号码中提取一定数量的行。 例如：一个有 200,000 行的电子表格有 20,000 行分配给十个电话号码。我们要提取每个电话号码的前十行。我们生成的文件将有 100 行按电话号码排序。

注意事项：

• 我们需要为每个电话号码提取可变数量的记录。
• 列数可能不同。
• 行数可以变化。
• 我们需要整行数据。
• 电话号码列可能位于每个电子表格中的不同位置。
• 电话号码的数量可能会有所不同。

这是一个适用于一个文件的代码，但不能复制到另一个工作表，因为每个工作表的“字段”、“条件”和“行”都会发生变化。

我们认为 IndexMatch 可能有效，但它只返回一项，而不是重复项。

我们没有 VBA 解决方案，因此我们手动执行此操作。

任何帮助将不胜感激！

Sub ExtractPh()

' Establish filter
' Choose first unique phone number

    Cells.Select
    Selection.AutoFilter
    ActiveSheet.UsedRange.AutoFilter Field:=25, Criteria1:= _
        "800-836-9207"

' Copy ten non-sequential rows from row 1 to row 82

   Rows("1:82").Select

    Selection.Copy

' Add rows to second sheet

    Sheets.Add After:=Sheets(Sheets.Count)
    Rows("1:1").Select
    ActiveSheet.Paste

' Move second to sheet to first position to save as separate file

    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Sheets("Sheet1").Move Before:=Sheets(1)

' Return to main data sheet

    Sheets("Test LKY job").Select

' Choose second unique phone number in column

    ActiveSheet.UsedRange.AutoFilter Field:=25, Criteria1:= _
        "800-907-3803"


' Choose second set of ten non-sequential rows and paste to first sheet

    Rows("6:26").Select
    Selection.Copy
    Sheets("Sheet1").Select
    Rows("12:12").Select
    ActiveSheet.Paste

' Return to main data sheet

    Sheets("Test LKY job").Select

' Choose third unique phone number in column

    ActiveSheet.UsedRange.AutoFilter Field:=25, Criteria1:= _
        "800-538-1668"

' Choose third set of non-sequential rows and paste to first sheet

    Rows("4:48").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Rows("22:22").Select
    ActiveSheet.Paste

End Sub

Answer 1

这里有一些示例代码，展示了如何过滤工作表，获取特定数量的可见行，然后将这些行复制到另一个工作表。

Sub Tester()

    Dim rng As Range, rngDest As Range

    Set rngDest = Sheet2.Range("A2")

    Set rng = GetFirstVisibleRows(ActiveSheet, 1, "A", 10)

    If Not rng Is Nothing Then
        rng.EntireRow.Copy rngDest
        Set rngDest = rngDest.Offset(rng.Cells.Count, 0)
    End If

End Sub

'filter the data on a sheet by a given value in a given column, then
'   return a range with the first x visible rows
Function GetFirstVisibleRows(sht As Worksheet, filterColumn As Long, _
                            filterValue, howManyRows As Long) As Range

    Dim c As Range, rngVis As Range, rngCopy As Range

    'filter the sheet and find the remaining visible rows (if any)
    With sht.UsedRange
        .AutoFilter
        .AutoFilter Field:=filterColumn, Criteria1:=filterValue
        On Error Resume Next '<< ignore error if no visible cells
        'offset/resize is to ignore the header row...
        Set rngVis = .Columns(1).Offset(1, 0).Resize(.Columns(1).Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0 '<< stop ignoring errors
    End With

    If Not rngVis Is Nothing Then
        'some visible (not filtered out) rows, so collect the first x of those...
        For Each c In rngVis.Cells
            If rngCopy Is Nothing Then
                Set rngCopy = c
            Else
                Set rngCopy = Application.Union(c, rngCopy)
            End If
            'exit loop if we have enough rows
            If rngCopy.Cells.Count >= howManyRows Then Exit For
        Next c
    End If

    Set GetFirstVisibleRows = rngCopy
End Function