如何使用ExcelVBA根據列拆分作業簿并復制到具有相同列值的作業簿？

這是我正在使用的子程式，它通過每個選項卡拆分回圈，并根據用戶指定的列“制造商名稱”將它們拆分為多個作業簿。

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

這最終導致了太多的作業簿。因此，相反，對于每個選項卡，我想將具有相同制造商的行復制到同一個作業簿。

uj5u.com熱心網友回復：

試試這個：

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
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set wbSrc = ActiveWorkbook
    
    Application.ScreenUpdating = False
    For Each ws In wbSrc.Worksheets
        If ws.Name <> "Open" Then
            For nRow = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
                
                v = ws.Cells(nRow, Col).Value 'get the specific Column
                
                If Not dict.exists(v) Then    'need a new workbook?
                     'add new workbook with one sheet
                     Set wsTmp = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
                     ws.Rows(1).Copy wsTmp.Range("A1") 'copy headers
                     dict.Add v, wsTmp.Range("A2")     'add key and the forst paste destination
                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
    Next ws
    
    Workbooks("Open_Spreadsheet_Split.xlsm").Activate 'ThisWorkbook?
    Sheets(1).Activate
End Sub

標籤：擅长 vba 循环 复制粘贴 工作表

上一篇：在計算SMA時處理空白單元格

下一篇：我想通過宏單擊工具列上的按鈕來加載基于javascript的加載項，誰能告訴我如何執行該程序？