Sub SplitDataByColumnA() Dim wsSource As Worksheet Dim wsDest As Worksheet Dim lastRow As Long Dim lastCol As Long Dim i As Long Dim dict As Object Dim key As Variant Dim rng As Range Dim cell As Range
' 設置源工作表 Set wsSource = ThisWorkbook.Sheets('Sheet1') ' 修改為你的工作表名稱
' 獲取源工作表的最后一行和最后一列 lastRow = wsSource.Cells(wsSource.rows.Count, 1).End(xlUp).Row lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 創(chuàng)建一個字典來存儲唯一值和對應的行 Set dict = CreateObject('Scripting.Dictionary')
' 遍歷列A中的數(shù)據(jù) For Each cell In wsSource.Range('A2:A' & lastRow) If Not dict.exists(cell.Value) Then dict.Add cell.Value, cell.Row Else dict(cell.Value) = dict(cell.Value) & ',' & cell.Row End If Next cell
' 遍歷字典中的每個鍵（唯一值） For Each key In dict.keys ' 創(chuàng)建一個新的工作表 Set wsDest = ThisWorkbook.Sheets.Add wsDest.Name = key ' 將工作表命名為當前鍵值
' 復制標題行到新工作表 wsSource.rows(1).Copy Destination:=wsDest.rows(1)
' 獲取當前鍵值對應的行號 Dim rows As Variant rows = Split(dict(key), ',')
' 復制對應的行到新工作表 For i = LBound(rows) To UBound(rows) wsSource.rows(rows(i)).Copy Destination:=wsDest.rows(wsDest.Cells(wsDest.rows.Count, 1).End(xlUp).Row + 1) Next i Next key
' 釋放對象 Set dict = Nothing Set wsSource = Nothing Set wsDest = Nothing
MsgBox '數(shù)據(jù)拆分完成！'End Sub
