Excel的VBA根据列值拆分到不同的工作簿

Question

下面的 VBA 代码从源数据表复制数据并将其粘贴到特定表上。但是，我还需要它来粘贴所有列的宽度并保持源数据表格式。这可能吗？感谢您的帮助。

Const Target_Folder As String = "" Dim wsSource 作为工作表，wsHelper 作为工作表 调暗最后一行和最后一列一样长

子分割数据集()

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

清洁：

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

结束子

私有子Init_Unique_List_Collection（ByRef col作为集合，ByVal SourceWS_LastRow作为长）

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

结束子

私有子拆分工作表（按Val Category_Name 作为变体）

Dim wbTarget As Workbook

Set wbTarget = Workbooks.Add

With wsSource
    
    With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
        .AutoFilter .Range("BQ1").Column, Category_Name
        
        .Copy
        
        'wbTarget.Worksheets(1).PasteSpecial xlValues
        wbTarget.Worksheets(1).Paste
        wbTarget.Worksheets(1).Name = Category_Name
        
        Call Retain_Formula(wbTarget)
        
        wbTarget.SaveAs Target_Folder & Category_Name & ".xlsx", 51
        wbTarget.Close False
        
    End With
    
End With

Set wbTarget = Nothing

结束子

私有子Retain_Formula（ByVal wb_object作为工作簿）

'// 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

结束子

Answer 1

您在

pastespecial

中评论的

SplitWorkbooks

应如下所示：

    With wbTarget.Worksheets(1)
        .PasteSpecial Paste:=xlPasteAll
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With

您不一定必须使用

With

块，但我认为它更整洁。