在Excel中将文件拆分成多个文件

我在Excel中有以下文件：

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

我想通过“名称”列（上面的例子中的3个文件）将它分成文件，如下所示：

文件： ABC.xsl

 NAME VALUE ABC 10 ABC 11 ABC 12 

文件： DEF.xsl

 NAME VALUE DEF 20 DEF 21 DEF 22 

文件： GHI.xsl

 NAME VALUE GHI 30 GHI 31 GHI 32 

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

在这一行上得到运行时错误ws.Range(vTitles).AutoFilter并在注释掉错误后，移动到ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)当vCol的值变空。

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

Answer 1

我认为这应该让你到你要去的地方。 下面的代码将每个组作为工作簿（.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 

Answer 2

只是为了logging，这个代码在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