Excel VBA按列值拆分工作簿：如何保留列宽与源格式？

你的需求完全可以实现，只需调整代码中的粘贴逻辑并补充列宽复制步骤，以下是修改后的完整代码：

Const Target_Folder As String = "<Target Folder Directory>"
Dim wsSource As Worksheet, wsHelper As Worksheet
Dim LastRow As Long, LastColumn As Long

Sub SplitDataset()
    
    Dim collectionUniqueList As Collection
    Dim i As Long
    
    Set collectionUniqueList = New Collection
    
    Set wsSource = ThisWorkbook.Worksheets("Registered_Business_Locations_-")
    Set wsHelper = ThisWorkbook.Worksheets("Helper")
    
    ' Clear Helper Worksheet
    wsHelper.Cells.ClearContents
    
    With wsSource
        .AutoFilterMode = False
        
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
        
        If .Range("A2").Value = "" Then
            GoTo Cleanup
        End If
        
        Call Init_Unique_List_Collection(collectionUniqueList, LastRow)
        
        Application.DisplayAlerts = False
        
        For i = 1 To collectionUniqueList.Count
                SplitWorksheet (collectionUniqueList.Item(i))
        Next i
        
        ActiveSheet.AutoFilterMode = False
        
    End With

Cleanup:

    Application.DisplayAlerts = True
    Set collectionUniqueList = Nothing
    Set wsSource = Nothing
    Set wsHelper = Nothing

End Sub

Private Sub Init_Unique_List_Collection(ByRef col As Collection, ByVal SourceWS_LastRow As Long)
    
    Dim LastRow As Long, RowNumber As Long
    
    ' Unique List Column
    wsSource.Range("BQ2:BQ" & SourceWS_LastRow).Copy wsHelper.Range("A1")
    
    With wsHelper
        
        If Len(Trim(.Range("A1").Value)) > 0 Then
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            .Range("A1:A" & LastRow).RemoveDuplicates 1, xlNo
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            .Range("A1:A" & LastRow).Sort .Range("A1"), Header:=xlNo
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            On Error Resume Next
            For RowNumber = 1 To LastRow
                col.Add .Cells(RowNumber, "A").Value, CStr(.Cells(RowNumber, "A").Value)
            Next RowNumber
           
        End If
    
    End With
    
End Sub

Private Sub SplitWorksheet(ByVal Category_Name As Variant)
    
    Dim wbTarget As Workbook
    Dim targetWs As Worksheet
    
    Set wbTarget = Workbooks.Add
    Set targetWs = wbTarget.Worksheets(1)
    
    With wsSource
        
        With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
            .AutoFilter .Range("BQ1").Column, Category_Name
            
            ' 复制筛选后的区域
            .Copy
            
            ' 粘贴源格式及数据
            targetWs.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
            ' 粘贴列宽
            targetWs.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            ' 清除剪贴板状态
            Application.CutCopyMode = False
            
            targetWs.Name = Category_Name
            
            Call Retain_Formula(wbTarget)
            
            wbTarget.SaveAs Target_Folder & Category_Name & ".xlsx", 51
            wbTarget.Close False
            
        End With
        
    End With
    
    Set targetWs = Nothing
    Set wbTarget = Nothing
    
End Sub

Private Sub Retain_Formula(ByVal wb_object As Workbook)
    
    '// assuming dataset always starts at row 2
    Dim col_index As Long, target_ws_lastrow As Long
    
    For col_index = 1 To LastColumn
        
        If wsSource.Cells(2, col_index).HasFormula Then
            '// transport formula
            wb_object.Worksheets(1).Cells(2, col_index).Formula = wsSource.Cells(2, col_index).Formula
            
            '// autofill formula to the last row
            target_ws_lastrow = wb_object.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            With wb_object.Worksheets(1)
                .Range(.Cells(2, col_index), .Cells(target_ws_lastrow, col_index)).Formula = .Cells(2, col_index).Formula
            End With
                    
        End If
    Next col_index
    
End Sub

关键修改说明 #

• 替换原直接粘贴逻辑，用xlPasteAllUsingSourceTheme完整保留源数据格式，包括字体、颜色、边框、数字格式等
• 新增xlPasteColumnWidths操作，确保目标工作表列宽与源表完全一致
• 增加Application.CutCopyMode = False释放剪贴板资源，避免后续操作受干扰
• 新增targetWs变量简化目标工作表引用，提升代码可读性

内容的提问来源于stack exchange，提问作者user24897968