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

问题描述 投票:0回答:1

下面的 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

结束子

excel vba
1个回答
0
投票

您在

pastespecial
中评论的
SplitWorkbooks
应如下所示:

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

您不一定必须使用

With
块,但我认为它更整洁。

© www.soinside.com 2019 - 2024. All rights reserved.