Блог

Главная - Вопросы по программированию - Excel VBA фильтрует несколько листов по имени и сохраняет как отдельный файл

Excel VBA фильтрует несколько листов по имени и сохраняет как отдельный файл

#excel #vba #filter

Вопрос:

У меня есть отчет с 4 листами: 1 первой страницей и 3 листами, которые необходимо отфильтровать по имени. После фильтрации листы должны быть сохранены в виде отдельного файла.

Сейчас я использую следующий код (см. Ниже), но у меня есть несколько вопросов:

  1. Как удалить данные, которые не соответствуют критериям? Поэтому, когда данные фильтруются по имени 1, все остальные имена должны быть удалены.
  2. Как скопировать первую страницу (лист1) вместе с 3 отфильтрованными листами в 1 файл? Теперь он копирует только 3 отфильтрованных листа. Первую страницу не нужно фильтровать.
  3. Как вставить данные в виде значений (теперь они вставлены в виде формулы)?
 Option Explicit

Sub AutoFilters()
Dim sheetsToFilter As Variant, sheetName As Variant
Dim sheetsColumnToFilterOn As Variant
Dim criteria As Variant, criterium As Variant
Dim iSht As Long
Dim pre As String

sheetsToFilter = Array("Sheet2", "Sheet3", "Sheet4")
sheetsColumnToFilterOn = Array(2, 3, 4)
criteria = Array("Name1", "Name2", "Name3")

pre = Format(Now, "dd-mm-yyyy")

Application.ScreenUpdating = False

For Each criterium In criteria
    For iSht = LBound(sheetsToFilter) To UBound(sheetsToFilter)
        Call Autofilter(ThisWorkbook.Worksheets(sheetsToFilter(iSht)).Range("A1"), CLng(sheetsColumnToFilterOn(iSht)), CStr(criterium))
    Next iSht

    Call CopySheet(sheetsToFilter, ThisWorkbook.Path amp; "" amp; criterium amp; " " amp; pre amp; ".xlsx")
Next criterium

Application.ScreenUpdating = True

End Sub


Sub Autofilter(rng As Range, col As Long, criteria As String)

With rng
    .Autofilter
    .Autofilter field:=col, Criteria1:=criteria amp; "*", VisibleDropDown:=True
End With

End Sub


Sub CopySheet(sheetsToFilter As Variant, shtName As String)

ThisWorkbook.Worksheets(sheetsToFilter).Copy
ActiveWorkbook.SaveAs Filename:=shtName, FileFormat:=xlWorkbookDefault
ActiveWorkbook.Close False

End Sub

Заранее спасибо!

Комментарии:

1. В q.3 Простой способ удалить формулы с листа, но сохранить форматирование на текущем листе-это ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value

2. Я бы использовал отдельную книгу «контроль». Напишите макрос, который открывает главный лист, сохраняет его как новое имя файла с помощью xlWorkbookDefault, а затем работайте с копией, удаляя строки в соответствии с любым фильтром, который вы хотите. Затем повторите то же самое для других книг. Это, вероятно, проще, чем копирование отдельных листов или данных. Немного зависит от размера файла.

Ответ №1:

Резервные Листы

  1. "<>" amp; Criteria(n) amp; "*"
  2. swb.Worksheets(Array(wsNames(0), wsNames(n))).Copy
  3. rg.Value = rg.Value 
 Option Explicit

Sub CreateBackups()
    
    Const wsNamesList As String = "Sheet1,Sheet2,Sheet3,Sheet4"
    Const CriteriaList As String = ",Name1,Name2,Name3"
    
    Dim fFields As Variant: fFields = VBA.Array(, 2, 3, 4)
    Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    
    Dim dStamp As String: dStamp = Format(Date, "dd-mm-yyyy")
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim dFolderPath As String: dFolderPath = swb.Path
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim ws As Worksheet
    Dim rg As Range
    Dim drg As Range ' Delete Range
    Dim dFilePath As String
    Dim n As Long
    
    For n = 1 To UBound(wsNames) ' 0 is front sheet
        swb.Worksheets(Array(wsNames(0), wsNames(n))).Copy
        Set dwb = ActiveWorkbook
        Set ws = dwb.Worksheets(wsNames(n))
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
        Set rg = ws.Range("A1").CurrentRegion
        rg.Value = rg.Value
        rg.AutoFilter fFields(n), "<>" amp; Criteria(n) amp; "*"
        Set drg = Nothing
        On Error Resume Next
        rg.Resize(rg.Rows.Count - 1, 1).Offset(1, fFields(n) - 1) _
            .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        ws.AutoFilterMode = False
        dFilePath = dFolderPath amp; "" amp; Criteria(n) amp; " " amp; dStamp amp; ".xlsx"
        Application.DisplayAlerts = False ' overwrite without alerts
        dwb.SaveAs dFilePath, xlWorkbookDefault
        Application.DisplayAlerts = True
        dwb.Close
    Next n

    Application.ScreenUpdating = False

    MsgBox "Today's worksheet backups created.", vbInformation, "Backup"

End Sub
Метки: