Excel VBA: извлечь переменное количество строк на переменное количество телефонных номеров - PullRequest
Новая
       35

Excel VBA: извлечь переменное количество строк на переменное количество телефонных номеров

0 голосов
/ 18 октября 2018

Мы стремимся автоматизировать этот процесс с помощью Excel VBA / макросов, потому что мы обрабатываем от двух до десяти электронных таблиц в неделю.Мы хотим извлечь определенное количество строк для каждого набора телефонных номеров.Например: электронная таблица с 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

1 Ответ

0 голосов
/ 18 октября 2018

Вот пример кода, показывающий, как можно отфильтровать лист, получить определенное количество видимых строк, а затем скопировать эти строки на другой лист. 

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
...