vba 在 Excel 中将文件拆分为多个文件

Split file into multiple files in Excel

提问by BreakPhreak

I have the following file in Excel:

我在 Excel 中有以下文件：

NAME VALUE
ABC 10
ABC 11
ABC 12
DEF 20
DEF 21
DEF 22
GHI 30
GHI 31
GHI 32

I'd like to split it into files by the 'Name' column (3 files for the example above) as following:

我想按“名称”列（上面示例中的 3 个文件）将其拆分为文件，如下所示：

File:ABC.xsl

文件：ABC.xsl

NAME VALUE
ABC 10
ABC 11
ABC 12

File:DEF.xsl

文件：DEF.xsl

NAME VALUE
DEF 20
DEF 21
DEF 22

File:GHI.xsl

文件：GHI.xsl

NAME VALUE
GHI 30
GHI 31
GHI 32

So far, tried the following macro: https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-wbs

到目前为止，尝试了以下宏：https: //sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-wbs

Got runtime errors on this line ws.Range(vTitles).AutoFilterAnd after commenting it out the error moved to ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)when vCol's value became empty.

在这一行出现运行时错误ws.Range(vTitles).AutoFilter并且在将其注释掉后，错误移至ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)whenvCol的值变为空。

What am I doing wrong please? (as VBA isn't my strongest point atm). Any advise regarding the snippet above or an alternative code that works would be a viable solution for me.

请问我做错了什么？（因为 VBA 不是我的最强点 atm）。任何关于上述代码片段或可行的替代代码的建议对我来说都是一个可行的解决方案。

回答by Dan Wagner

I think this ought to get you where you're going. The code below saves each group as a workbook (.xls format) in the same directory as the workbook that houses the VBA (i.e. ThisWorkbook):

我认为这应该能让你到达你要去的地方。下面的代码将每个组作为工作簿（.xls 格式）保存在与包含 VBA 的工作簿（即ThisWorkbook）相同的目录中：

Option Explicit
Sub SplitIntoSeperateFiles()

Dim OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim FilterRange As Range
Dim UniqueNames As New Collection
Dim LastRow As Long, LastCol As Long, _
    NameCol As Long, Index As Long
Dim OutName As String

'set references and variables up-front for ease-of-use
Set DataSheet = ThisWorkbook.Worksheets("Sheet1")
NameCol = 1
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol))

'loop through the name column and store unique names in a collection
For Index = 2 To LastRow
    On Error Resume Next
        UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol)
    On Error GoTo 0
Next Index

'iterate through the unique names collection, writing 
'to new workbooks and saving as the group name .xls
Application.DisplayAlerts = False
For Index = 1 To UniqueNames.Count
    Set OutBook = Workbooks.Add
    Set OutSheet = OutBook.Sheets(1)
    With FilterRange
        .AutoFilter Field:=NameCol, Criteria1:=UniqueNames(Index)
        .SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1")
    End With
    OutName = ThisWorkbook.FullName
    OutName = Left(OutName, InStrRev(OutName, "\"))
    OutName = OutName & UniqueNames(Index)
    OutBook.SaveAs Filename:=OutName, FileFormat:=xlExcel8
    OutBook.Close SaveChanges:=False
    Call ClearAllFilters(DataSheet)
Next Index
Application.DisplayAlerts = True

End Sub

'safely clear all the filters on data sheet
Sub ClearAllFilters(TargetSheet As Worksheet)
    With TargetSheet
        TargetSheet.AutoFilterMode = False
        If .FilterMode Then
            .ShowAllData
        End If
    End With
End Sub

回答by BreakPhreak

Just for the record, this code worked for me on Windows (but for some reason not on Mac):

只是为了记录，这段代码在 Windows 上对我有用（但由于某种原因不适用于 Mac）：

Option Explicit
Sub SplitIntoSeparateFiles()

Dim OutBook, MyWorkbook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim FilterRange As Range
Dim UniqueNames As New Collection
Dim LastRow As Long, LastCol As Long, _
    NameCol As Long, Index As Long
Dim OutName As String

'set references and variables up-front for ease-of-use
'the current workbook is the one with the primary data, more workbooks will be created later
Set MyWorkbook = ActiveWorkbook 
Set DataSheet = ActiveSheet 'was ThisWorkbook.Worksheets("Sheet1"), now works for every sheet

NameCol = 1
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'LastRow = DataSheet.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol))

'loop through the name column and store unique names in a collection
For Index = 2 To LastRow
    On Error Resume Next
        UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol)
    On Error GoTo 0
Next Index

'iterate through the unique names collection, writing
'to new workbooks and saving as the group name .xls
Application.DisplayAlerts = False
For Index = 1 To UniqueNames.Count
    Set OutBook = Workbooks.Add
    Set OutSheet = OutBook.Sheets(1)
    With FilterRange
        .AutoFilter Field:=NameCol, Criteria1:=UniqueNames(Index)
        .SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1")
    End With
    OutName = MyWorkbook.Path + "\" 'was OutName = Left(OutName, InStrRev(OutName, "\"))
                                    'the question here would be to modify the separator for every platform

    OutName = OutName & UniqueNames(Index)
    OutBook.SaveAs Filename:=OutName, FileFormat:=xlExcel8
    OutBook.Close SaveChanges:=False
    Call ClearAllFilters(DataSheet)
Next Index
Application.DisplayAlerts = True

End Sub

'safely clear all the filters on data sheet
Sub ClearAllFilters(TargetSheet As Worksheet)
    With TargetSheet
        TargetSheet.AutoFilterMode = False
        If .FilterMode Then
            .ShowAllData
        End If
    End With
End Sub