Sub FileSplitter() Dim i As Long Dim LastRow As Long Dim ColNum As Long Dim CountNum As Long Dim DictCount As Long Dim Dict As Object Dim Arr Dim wks As Worksheet Dim Path As String Dim wb As Workbook
Application.StatusBar = ''
Set wks = ActiveSheet
'獲取所選單元格所在的列號(hào).'如果選擇了多個(gè)區(qū)域,'獲取最左側(cè)列的列號(hào) ColNum = Selection.Column'如果所選列不包含數(shù)據(jù),則發(fā)送消息.'第1行是列標(biāo)題,因此<2是條件. If WorksheetFunction.CountA(Columns(ColNum)) < 2 Then MsgBox '所選列不包含數(shù)據(jù)' Exit Sub End If
Application.ScreenUpdating = False Application.DisplayAlerts = False
'使用字典獲取所選列唯一項(xiàng)列表 Set Dict = CreateObject('Scripting.Dictionary') LastRow = wks.Cells.SpecialCells(xlLastCell).Row'將所選列值放入數(shù)組中 ReDim Arr(1 To LastRow - 1, 1 To 1) Arr = wks.Range(Cells(2, ColNum), Cells(LastRow, ColNum))'遍歷所有數(shù)組項(xiàng),創(chuàng)建唯一值列表 For i = 1 To LastRow - 1 On Error Resume Next Dict.Add Arr(i, 1), Arr(i, 1) On Error GoTo 0 Next i'獲取Dictionary中的值到Arr DictCount = Dict.Count ReDim Arr(DictCount) Arr = Dict.Items Set Dict = Nothing
'提取代碼所在工作簿路徑. 在此保存所有文件. Path = ActiveWorkbook.Path
'基于數(shù)組項(xiàng)目應(yīng)用篩選，復(fù)制并粘貼到目標(biāo)工作簿'目標(biāo)工作簿名與數(shù)組項(xiàng)目名相同 For i = LBound(Arr) To UBound(Arr) '打開并復(fù)制數(shù)據(jù)到新工作簿 Set wb = Workbooks.Add wks.AutoFilterMode = False wks.UsedRange.AutoFilter Field:=ColNum,Criteria1:=Arr(i) wks.AutoFilter.Range.Copy wb.Worksheets(1).Range('A1').PasteSpecial (xlPasteAll) wb.Worksheets(1).Range('A1').Select wb.SaveAs Filename:=Path & '\' & Trim(Arr(i)), FileFormat:=51 wb.Close Application.CutCopyMode = False CountNum = CountNum + 1 Application.StatusBar = '完成生成文件' & CountNum & ' of ' & DictCount & ' -' & Arr(i) Next i Application.StatusBar = DictCount & ' 個(gè)文件被生成' wks.AutoFilterMode = False Application.DisplayAlerts = True Application.ScreenUpdating = TrueEnd Sub聯(lián)系客服
