如何根据列拆分工作簿并使用Excel VBA复制到具有相同列值的工作簿？

Question

这是我正在使用的子程序，它通过每个选项卡拆分循环，并根据用户指定的列“制造商名称”将它们拆分为多个工作簿。

Sub SplitSheetIntoMultWkbksBasedOnCol(Col As String)      
 Dim objWorksheet As Excel.Worksheet
 Dim nLastRow, nRow, nNextRow As Integer
 Dim strColumnValue As String
 Dim objDictionary As Object
 Dim varColumnValues As Variant
 Dim varColumnValue As Variant
 Dim objExcelWorkbook As Excel.Workbook
 Dim objSheet As Excel.Worksheet

 Dim wsSheet As Worksheet

 For Each wsSheet In Worksheets
    If wsSheet.Name <> "Open" Then
        wsSheet.Activate
        
        Set objWorksheet = ActiveSheet
        nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
        
        Set objDictionary = CreateObject("Scripting.Dictionary")
        
        For nRow = 2 To nLastRow
           'Get the specific Column
           strColumnValue = objWorksheet.Range(Col & nRow).Value
    
           If objDictionary.Exists(strColumnValue) = False Then
              objDictionary.Add strColumnValue, 1
           End If
        Next
        
        varColumnValues = objDictionary.Keys
        
        For i = LBound(varColumnValues) To UBound(varColumnValues)
            varColumnValue = varColumnValues(i)

           'Create a new Excel workbook
           Set objExcelWorkbook = Excel.Application.Workbooks.Add
           Set objSheet = objExcelWorkbook.Sheets(1)
           objSheet.Name = objWorksheet.Name
    
           objWorksheet.Rows(1).EntireRow.Copy
           objSheet.Activate
           objSheet.Range("A1").Select
           objSheet.Paste


            For nRow = 2 To nLastRow
              If CStr(objWorksheet.Range(Col & nRow).Value) = CStr(varColumnValue) Then
                 objWorksheet.Rows(nRow).EntireRow.Copy
    
                 nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
                 objSheet.Range("A" & nNextRow).Select
                 objSheet.Paste
                 objSheet.Columns("A:B").AutoFit
              End If
            Next
        Next
    
    End If
 Next wsSheet

 Workbooks("Open_Spreadsheet_Split.xlsm").Activate
 Sheets(1).Activate
End Sub

这最终导致工作簿过多。因此，对于每个选项卡，我想将具有相同制造商的行复制到相同的工作簿。

Answer 1

编辑：确保每个来源 sheet 的 headers 包含在每个目的地 sheet.

试试这个：

Sub SplitSheetIntoMultWkbksBasedOnCol(Col As String)
    
    Dim wbSrc As Workbook, ws As Worksheet, wsTmp As Worksheet
    Dim dict As Object, lastRow As Long, nRow As Long, v
    Dim dictHeader As Object 'for tracking whether headers have been copied
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set wbSrc = ActiveWorkbook
    
    Application.ScreenUpdating = False
    For Each ws In wbSrc.Worksheets
        If ws.Name <> "Open" Then
            Set dictHeader = CreateObject("Scripting.Dictionary") 'reset header-tracking dictionary
            For nRow = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
                
                v = ws.Cells(nRow, Col).Value 'get the specific Column
                
                'need a new workbook?
                If Not dict.exists(v) Then
                     Set wsTmp = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'add new workbook with one sheet
                     dict.Add v, wsTmp.Range("A1")     'add key and the first paste destination
                End If
                
                'first row from this sheet for this value of `v`?
                If Not dictHeader.exists(v) Then
                    ws.Rows(1).Copy dict(v)            'copy headers from this sheet
                    Set dict(v) = dict(v).Offset(1, 0) 'set next paste position
                    dictHeader.Add v, True             'flag header as copied
                End If
                
                ws.Rows(nRow).Copy dict(v)         'copy the current row
                Set dict(v) = dict(v).Offset(1, 0) 'set next paste position
            Next nRow
        End If 'not "open" sheet
    Next ws
    
    Workbooks("Open_Spreadsheet_Split.xlsm").Activate 'ThisWorkbook?
    Sheets(1).Activate
End Sub

如何根据列拆分工作簿并使用Excel VBA复制到具有相同列值的工作簿？

How to Split a Workbook Based on a Column and Copy to the Workbook with the Same Column Value Using Excel VBA?

excel

vba

loops

copy-paste

worksheet