基于多条件循环批量生成指定命名Excel文件的VBA改造需求

Requirement #

• Process Excel data in a loop using up to 20 conditions
• For each condition:
  1. Filter the specified data range ($A$2:$AQ$4652) with two criteria: Field 22 is non-blank, Field 5 matches the current condition
  2. Copy the filtered rows from columns W to AQ
  3. Paste the values into a new workbook, apply formatting (alignment, date formats)
  4. Save the new workbook with a name like PO [condition].xlsx in the designated folder
  5. Repeat until all conditions are processed

Existing Single-Condition Code #

Sub Converter()
   
    Sheets("SHEET INPUT").Select
    ActiveSheet.Range("$A$2:$AQ$4652").AutoFilter Field:=22, Criteria1:="<>"
    
    ActiveSheet.Range("$A$2:$AQ$4652").AutoFilter Field:=5, Criteria1:="1"
    Range("W2:AQ2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Columns.AutoFit
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    Range("B1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "m/d/yyyy"
    Range("N1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "m/d/yyyy"
    Range("R1").Select
    ActiveWorkbook.SaveAs Filename:="C:\Users\BJ900265\Documents\Z-Spam File\Converter Temap\PO 1.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

Modified Multi-Condition Code #

Sub MultiConditionConverter()
    Dim wsInput As Worksheet
    Dim conditions As Variant
    Dim cond As Variant
    Dim savePath As String
    Dim filteredRange As Range
    Dim newWB As Workbook
    
    ' Set reference to input worksheet
    Set wsInput = ThisWorkbook.Sheets("SHEET INPUT")
    ' Define your conditions (add up to 20 values as needed)
    conditions = Array("1", "2", "3", "4", "5") ' Replace with actual condition values
    ' Set target save folder (ensure this path exists)
    savePath = "C:\Users\BJ900265\Documents\Z-Spam File\Converter Temap\"
    
    ' Disable screen updating to speed up processing
    Application.ScreenUpdating = False
    
    ' Loop through each condition in the array
    For Each cond In conditions
        ' Clear any existing filters on the input sheet
        wsInput.AutoFilterMode = False
        
        ' Apply base filter: Field 22 (column V) is non-blank
        wsInput.Range("$A$2:$AQ$4652").AutoFilter Field:=22, Criteria1:="<>"
        ' Apply current condition filter: Field 5 (column E) matches the condition
        wsInput.Range("$A$2:$AQ$4652").AutoFilter Field:=5, Criteria1:=cond
        
        ' Get visible rows in columns W to AQ (skip header if needed)
        On Error Resume Next ' Handle case where no rows match the filter
        Set filteredRange = wsInput.Range("W2:AQ" & wsInput.Cells(wsInput.Rows.Count, "W").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' Proceed only if there are visible rows to copy
        If Not filteredRange Is Nothing Then
            ' Create new workbook
            Set newWB = Workbooks.Add
            
            ' Paste values to the new workbook's first sheet
            filteredRange.Copy
            newWB.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
            
            ' Format the new sheet
            With newWB.Sheets(1)
                .Columns.AutoFit
                ' Set alignment for all cells
                .Cells.HorizontalAlignment = xlCenter
                .Cells.VerticalAlignment = xlBottom
                ' Set date format for columns B, N, R
                .Columns("B").NumberFormat = "m/d/yyyy"
                .Columns("N").NumberFormat = "m/d/yyyy"
                .Columns("R").NumberFormat = "m/d/yyyy"
            End With
            
            ' Save and close the new workbook
            newWB.SaveAs Filename:=savePath & "PO " & cond & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            newWB.Close SaveChanges:=False
            
            ' Reset filtered range reference
            Set filteredRange = Nothing
        End If
    Next cond
    
    ' Clean up: remove filters from input sheet
    wsInput.AutoFilterMode = False
    ' Re-enable screen updating
    Application.ScreenUpdating = True
    
    ' Notify user when processing is complete
    MsgBox "All conditions processed successfully!", vbInformation
End Sub

Key Improvements & Notes #

• Condition Array: The conditions array holds all your target values (up to 20). Update this array with your actual condition strings/numbers.
• Explicit References: Replaced Select/Selection with direct worksheet/range references to avoid runtime errors and improve performance.
• Error Handling: Added error handling to skip conditions that have no matching rows.
• Efficiency: Disabled screen updating during the loop to reduce flicker and speed up execution.
• Cleanup: Ensures filters are cleared after each iteration and restored at the end.
• Save Path: Verify the savePath exists before running the code; create the folder manually if needed.

Content of the question comes from stack exchange, question author Sunny