Блог

У меня есть лист с данными более 30 000 строк, и я хочу скопировать все строки в новый файл Excel, если столбец определенной (например, «B») строки содержит определенные значения (список этих значений будет в другом листе «Code»). Так, например:

1. На листе «Код» у меня есть десять (может быть даже 30) разных чисел (критериев) в столбце «A».
2. Запустите поиск, чтобы скопировать все строки (в новый файл Excel), содержащие любое из этих чисел, из листа «Код» в столбце «A».

Пока не очень хорошо разбираюсь в VBA, но работаю над этим 🙂 Спасибо всем за помощь!

Фильтровать по нескольким критериям и экспортировать в другую книгу

• Просто чтобы продемонстрировать, почему вопрос не так хорошо принят. Это своего рода 50 вопросов в одном.
• Отрегулируйте значения в разделе константы, и все должно быть готово.
• «Лист2» на самом деле является вашим рабочим листом «Code». «Лист1» — это первый рабочий лист.

Код

 Option Explicit

Sub exportMultiToWorkbook()
    
    ' Error Handler
    
    ' Initialize error handling.
    Const procName As String = "exportMultiToWorkbook"
    On Error GoTo clearError ' Turn on error trapping.
    
    ' Constants
    
    ' Criteria
    Const critName As String = "Sheet2"
    Const critFirstCell As String = "A2"
    ' Source
    Const srcName As String = "Sheet1"
    Const srcFirstCell As String = "A1"
    Const srcCritColumn As Long = 2
    Dim wbs As Workbook
    Set wbs = ThisWorkbook ' The workbook containing this code.
    ' Target
    Const tgtFirstCell As String = "A1"
    Dim tgtPath As String
    ' The same path as Source Workbook ('wbs'). Change if necessary.
    tgtPath = wbs.Path amp; Application.PathSeparator amp; "Criteria"
    ' Other
    Dim Success As Boolean
    Dim AfterCop As Boolean
    
    ' Criteria
    
    ' Define Criteria Worksheet ('crit').
    Dim crit As Worksheet
    Set crit = wbs.Worksheets(critName)
    ' Define Criteria First Cell Range ('fcel').
    Dim fcel As Range
    Set fcel = crit.Range(critFirstCell)
    ' Define Criteria Processing Column Range ('pcr').
    Dim pcr As Range
    Set pcr = fcel.Resize(crit.Rows.Count - fcel.Row   1)
    ' Define Criteria Last Non-Empty Cell Range ('lcel').
    Dim lcel As Range
    Set lcel = pcr.Find(What:="*", _
                       LookIn:=xlFormulas, _
                       SearchDirection:=xlPrevious)
    ' Validate Last Non-Empty Cell Range.
    If lcel Is Nothing Then
        GoTo ProcExit
    End If
    ' Define Criteria Column Range ('cr').
    Dim cr As Range
    Set cr = crit.Range(fcel, lcel)
    ' Write values from Criteria Column Range to 1D Criteria Array ('Criteria'),
    ' probably using Criteria 2D Array ('Crit2D').
    Dim Criteria As Variant
    Dim i As Long
    If cr.Rows.Count > 1 Then
    ' Criteria Column Range has multiple cells (rows).
        ' Write values from Criteria Range to Criteria 2D Array.
        Dim Crit2D As Variant
        Crit2D = cr.Value
        ' Write values from Criteria 2D Array to 1D Criteria Array.
        ReDim Criteria(1 To UBound(Crit2D, 1))
        For i = 1 To UBound(Crit2D)
            Criteria(i) = CStr(Crit2D(i, 1)) ' AutoFilter prefers strings.
        Next i
    Else
    ' Criteria Column Range has one cell (row) only.
        ' Write the only value from Criteria Column Range to Criteria Array.
        ReDim Criteria(1)
        Criteria(1) = CStr(cr.Value) ' AutoFilter prefers strings.
    End If
         
    ' Source
         
    ' Define Source Worksheet ('src').
    Dim src As Worksheet
    Set src = wbs.Worksheets(srcName)
    ' Define Source First Cell Range ('fcel').
    Set fcel = src.Range(srcFirstCell)
    ' Define Source Last Cell Range ('lcel').
    Set lcel = fcel.End(xlToRight).End(xlDown)
    ' Define Copy Range
    Dim cop As Range
    Set cop = src.Range(fcel, lcel)
    ' Turn off screen updating.
    Application.ScreenUpdating = False
    ' Turn off filter, if on.
    If src.FilterMode Then
        cop.AutoFilter
    End If
    ' Filter data. AutoFilter prefers the whole range.
    cop.AutoFilter Field:=srcCritColumn, _
                   Criteria1:=Criteria, _
                   Operator:=xlFilterValues
    ' Enable the use of 'SafeExit' instead of 'ProcExit' after possible error.
    AfterCop = True
    
    ' Target
    
    ' Add a new workbook.
    With Workbooks.Add
        ' Copy Copy Range to the first sheet of a new workbook.
        cop.Copy .Worksheets(1).Range(tgtFirstCell)
        ' I prefer to save this way; always a different file.
        tgtPath = tgtPath amp; " " amp; Format(Now, "YYYYMMDD_HHMMSS")
        .SaveAs Filename:=tgtPath, _
                FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
         ' If you prefer the file to have the same name and for it to be
         ' overwritten without Excel complaining, then rather use the following:
'        Application.DisplayAlerts = False
'        .SaveAs Filename:=tgtPath, _
'                FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
'        Application.DisplayAlerts = True
        .Close
    End With
    Success = True
         
SafeExit:
    
    ' Source
    
    ' Turn off filter.
    cop.AutoFilter
    wbs.Saved = True
    
    ' Turn on screen updating.
    Application.ScreenUpdating = True
    
ProcExit:
   
   ' Inform user.
        
    If Success Then
        MsgBox Prompt:="Created file '" amp; tgtPath amp; "'.", _
               Buttons:=vbInformation, _
               Title:="Multiple Criteria Filter - Success"
    Else
        MsgBox Prompt:="Could not finish task.", _
               Buttons:=vbCritical, _
               Title:="Multiple Criteria Filter - Fail"
    End If

    Exit Sub

clearError:
    Debug.Print "'" amp; procName amp; "': " amp; vbLf _
              amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
              amp; "        " amp; Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    If Not AfterCop Then
        GoTo ProcExit
    Else
        GoTo SafeExit
    End If

End Sub
  

Я понимаю, что вы новичок и не хочу отговаривать вас от обращения за помощью в будущем. Пожалуйста, попытайтесь задать более конкретные вопросы в будущем. Например, вы можете спросить, как узнать, соответствует ли значение одной ячейки значению любой ячейки в диапазоне ячеек. Тем не менее, у меня такое чувство, что вы не знали, с чего начать, поэтому я попробую. VBasic 2008 уже предоставил отличный ответ и фактически написал для вас код, которого вы не должны ожидать. Код VBasic 2008 великолепен, но он больше, чем вам нужно, а также немного сложен для понимания новичком. В приведенном ниже коде вам действительно нужно всего лишь изменить три строки «set» в процедуре CopyFilteredDemo.

Ниже приведен простой код, который делает несколько упрощающих предположений. Исходя из вашего запроса, я предполагаю, что это соответствует вашим потребностям. Если нет, добавьте больше конкретики. Многие из этих ограничений предположений, перечисленных ниже, легко преодолеваются, но я не хочу писать код для этого.

1. Либо исходные и целевые книги одинаковы, либо они обе открыты. (Я тестировал только разные листы в одной книге, но он должен работать во всех книгах.)
2. Исходные и целевые листы не совпадают. Намеренно возникает ошибка, если они совпадают.
3. Целевой рабочий лист уже существует. $) Рабочий лист desitnation будет полностью очищен и перезаписан. Измените True на False в CopyFilteredDemo, чтобы передать, чтобы передать False в CopyFiltered .
4. Выполняйте поиск только в первом столбце исходного диапазона для точного соответствия в диапазоне фильтров. Поскольку копируется вся строка, не имеет значения, какой столбец вы задаете в качестве первого столбца в fromRange. Просто выберите столбец, который вы хотите сравнить со значениями в filterRange.
5. Если он не отфильтрован, будет скопирована вся строка рабочего листа.
6. В критериях фильтрации нет дубликатов. Я не проверял это, чтобы увидеть, вызывает ли это дубликаты на целевом листе.
7. Производительность не проверялась на тысячах строк. Если вы видите проблемы, сначала установите приложение.Обновление экрана = False. Включите его снова в конце. Убедитесь, что у вас есть обработка ошибок, которую можно включить в случае ошибки. В противном случае обновление экрана останется отключенным, что, как вы обнаружите, крайне нежелательно. Если это выходит за рамки вашего текущего уровня комфорта, не отключайте обновление экрана.

В качестве схемы основной процедурой является CopyFiltered, которая копирует данные с одного листа на другой. Эта процедура вызывает функцию IsInRange, которая возвращает true, если аргумент valueToFind точно соответствует значению в диапазоне, указанном аргументом RangeToSearch . Итак, при сравнении исходного диапазона (fromRange) с критериями фильтрации (filterRange) сравнивается первый столбец fromRange . fromRange не определяет, какие столбцы копируются, поскольку вы запросили скопировать целые строки. Скорее, fromRange имеет 2 цели. Во-первых, он определяет строки, из которых нужно копировать. Во-вторых, первый столбец fromRange сравнивается с filterRange для соответствия.

Я поместил в код большое количество комментариев, поэтому я надеюсь, что его относительно легко понять.

 Option Explicit
' Option Explicit must be the first line of code in the module. 
' It forces you to declare every variable.  It may seem a nuisance
' to a beginner, but you will quickly learn its value.  It will 
' keep you from spelling the same variable two ways and failing 
' to understand why your code failed.  There are other benefits 
' that you'll pick up over time, such as conserving memory and
' forcing data typing.

Public Function IsInRange(ByVal valueToFind, ByVal RangeToSearch As Range)
    ' If any cell in RangeToSearch = valueToFind, return True
    ' Else return False.
    Dim x
   
    ' If valueToFind is not in RangeToSearch, expect
    ' error 91.  That's okay, we'll handle that error
    ' and return False.  If we get a differnt error,
    ' we'll raise it.
    On Error GoTo EH
    x = RangeToSearch.Find(valueToFind)
    On Error GoTo 0

    ' If we made it this far, we found it!
    IsInRange = True


Exit Function
EH:
    If Err.Number = 91 Then
        ' this error is expected if valueToFind is not in RangeToSearch
        IsInRange = False
        Err.Clear
    Else
        ' Unexpected error.
        Err.Raise Number:=Err.Number, Source:=Err.Source _
                  , Description:=Err.Description
    End If
End Function


Sub CopyFiltered(ByVal fromRange As Range, ByVal toRange As Range _
                 , ByVal filterRange As Range _
                 , Optional clearFirst As Boolean = True)

' Arguments:
'   fromRange: the full range from which to copy
'   toRange: the top left cell fromRange will be pasted to the
'              top left cell of toRange.  The size of toRange
'              is irrelevant.  Only the top left cell is used
'              for reference.
'   fitlerRange: a range containing values with which to filter.
'   clearFirst: if True, clear all content from range containing
'               toRange before pasting new values.

    Dim rng As Range, rowOffset As Integer
    Dim rowNum As Integer, colNum As Integer, i As Integer
    Dim errMsg As String, cell As Range
    
    Set toRange = toRange.Cells(1, 1)
    Set fromRange = fromRange.Columns(1)
    
    ' If fromRange and toRange are on the same worksheet,
    ' raise an exception.
    If fromRange.Worksheet.Name = toRange.Worksheet.Name Then
        errMsg = "fromRange and toRange cannot be on the same worksheet."
        Err.Raise 1000, "CopyFiltered", errMsg
        Exit Sub
    End If
    
    ' Clear all content from the destination worksheet.
    toRange.Worksheet.Cells.ClearContents

    '
    ' Loop through each row of fromRange
    rowOffset = -1
    For i = 1 To fromRange.Rows.Count
        Set cell = fromRange.Cells(i, 1)
        Debug.Print cell.Address
        ' If the the cell in the first column of fromRange
        ' exaclty equals any cell in filterRange, proceed.
        If IsInRange(cell.Value, filterRange) Then
            ' Add one to rowOffset, so we copy this row
            ' below the last pasted row of the sheet
            ' containing toRange
            rowOffset = rowOffset   1
            cell.EntireRow.Copy toRange.Offset(rowOffset, 0).EntireRow
        End If
    Next i

End Sub



Sub CopyFilteredDemo()
    Dim fromRange As Range, toRange As Range, filterRange As Range
    
    ' Set our to, from and filter ranges
    Set fromRange = Sheets("Sheet1").Range("c10:c40")
    Set toRange = Sheets("Sheet2").Range("A2")
    Set filterRange = Sheets("Sheet1").Range("B2:B6")
    
    ' Run our filtered copy procedure.
    CopyFiltered fromRange, toRange, filterRange, True
End Sub