excel - 基于名为“Carrier”的指定列的 VBA 宏创建列值或将列值拆分到新工作簿中

Question

我对 VBA 宏非常陌生，我正在尝试创建一个基于特定列拆分数据并为每个列值创建一个新工作簿的宏。

下面是我的代码，它给出了很多错误，我很困惑处理它......下面的代码太长了有什么办法可以缩短 main 是正确的输出

Sub ExportData()

'Declare variables
Dim ArrayItem As Long
Dim ws As Worksheet
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range

'Set the worksheet to
Set ws = Sheets("POL")

'Set the save path for the files created
SavePath = "C:\Folder"

'Set variables for the column we want to separate data based on
ColumnHeadingInt = ActiveWorkbook.Worksheets("POL").Match(Range("Carrier").Value, Range("POL[#Headers]"), 0)
ColumnHeadingStr = "POL[[#All],[" & Range("Carrier").Value & "]]"

'Turn off screen updating to save runtime
Application.ScreenUpdating = False

'Create a temporary list of unique values from the column we want to
'separate our data based on
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("UniqueValues"), Unique:=True

'Sort our temporary list of unique values
ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Add unique field values into an array
'ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("IV2:IV" & Rows.Count).SpecialCells(xlCellTypeConstants))
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))

'Delete the temporary values
ws.Range("UniqueValues").EntireColumn.Clear

'Loop through our array of unique field values, copy paste into new workbooks and save
For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
    ws.ListObjects("POL").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    ws.Range("POL[#All]").SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll
    ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), " YYYY-MM-DD ") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws.ListObjects("POL").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem

ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True
    
End Sub

边框被添加到所有空单元格中，我也是这样编码的

'Autofit
                
                Sheets("POL").UsedRange.Columns.AutoFit
                 
                
                'Sorting the range to compact the data.
                With .Parent.Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
                    .SetRange RngRange02
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                
                'Apply Border
                
                With Sheets("POL").UsedRange.Borders
                  .LineStyle = xlContinuous
                   .Weight = xlThin
                   .ColorIndex = xlAutomatic
                 End With

我又添加了 3 个设置来更改工作表名称并自动调整所有 Excel 工作表中的列。一切正常，但问题在于也适用于空单元格的边框

标签： excelvba

Answer 1

试试这个：

Sub ExportAndSave()
    
    'Declarations.
    Dim RngSourceData As Range
    Dim RngTarget As Range
    Dim RngRange01 As Range
    Dim RngRange02 As Range
    Dim StrCarrierColumnHeader As String
    Dim StrSavePath As String
    Dim StrMultipleFileMessage As String
    Dim DblCarrierColumnRelativeColumn As Double
    Dim DblCounter01 As Double
    Dim DblCounter02 As Double
    Dim WkbSource As Workbook
    Dim WkbTarget As Workbook
    
    'Turning off screen updating.
    Application.ScreenUpdating = False
    
    'Setting variables.
    Set WkbSource = ActiveWorkbook
    Set RngSourceData = WkbSource.Sheets("POL").Range("I1:J6")
    StrCarrierColumnHeader = "Carrier"
    StrSavePath = "C:\Folder\"
    
    'Setting DblCarrierColumnRelativeColumn to determine what column within RngSourceData _
    contains the StrCarrierColumnHeader. If no such column is found, the subroutine is terminated.
    On Error Resume Next
    DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
    If Err <> 0 Then
        MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    On Error GoTo 0
    
    'Setting RngRange01 to cover the data in the carrier column.
    Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
    
    'Covering each cell in RngRange01.
    DblCounter01 = 0
    For Each RngTarget In RngRange01.Cells
        
        'Checking if the code had already met the carrier of RngTarget.
        If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
            
            'Cheking if any file dedicated to the given carrier already exists for today.
            If Dir(StrSavePath & RngTarget.Value & Format(Now(), " YYYY-MM-DD ") & ".xlsx") = "" Then
                'If no such file exists, it is created and saved.
                Set WkbTarget = Workbooks.Add
                WkbTarget.SaveAs StrSavePath & RngTarget.Value & Format(Now(), " YYYY-MM-DD ") & ".xlsx"
            Else
                'Is it does exist, the name is "shifted".
                DblCounter02 = 2
                Do Until Dir(StrSavePath & RngTarget.Value & Format(Now(), " YYYY-MM-DD ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
                    DblCounter02 = DblCounter02 + 1
                Loop
                'Carrier and relative file are copied in StrMultipleFileMessage.
                StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & Format(Now(), " YYYY-MM-DD ") & "(" & DblCounter02 & ")" & ".xlsx"
                Set WkbTarget = Workbooks.Add
                WkbTarget.SaveAs StrSavePath & RngTarget.Value & Format(Now(), " YYYY-MM-DD ") & "(" & DblCounter02 & ")" & ".xlsx"
            End If
            
            'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
            Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
            
            With RngRange02
                
                'Copying values.
                RngSourceData.Copy RngRange02
                
                'Filtering the range to clear the list of unwanted data.
                .AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
                .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
                .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
                
                'Removing the filter.
                .AutoFilter
                
                'Sorting the range to compact the data.
                With .Parent.Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
                    .SetRange RngRange02
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                
            End With
            
            'Saving and closing WkbTarget.
            WkbTarget.Close savechanges:=True
            
        End If
        
        'Setting DblCounter01.
        DblCounter01 = DblCounter01 + 1
    Next
    
    'Enabling screen updating.
    Application.ScreenUpdating = True
    
    'Reporting if any carrier had its data reported in a "twin" file.
    If StrMultipleFileMessage <> "" Then
        StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
        MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
    End If
    
End Sub

您可能必须编辑一些变量的设置（我肯定会说是 RngSourceData）。