在Excel中将文件拆分为多个文件
在Excel中将文件拆分为多个文件
提问于 2014-04-16 10:18:56
我在Excel中有以下文件：
NAME VALUE
ABC 10
ABC 11
ABC 12
DEF 20
DEF 21
DEF 22
GHI 30
GHI 31
GHI 32我想按照'Name‘列(上面示例的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到目前为止，尝试了以下宏：https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-wbs
获得这行ws.Range(vTitles).AutoFilter的运行时错误，并在注释掉它之后，当vCol的值变为空时，错误转移到vCol。
请问我做错什么了？(因为VBA不是我最擅长的一点atm)。对我来说，任何关于上面的代码片段或其他代码的建议都是可行的解决方案。
回答 2
Stack Overflow用户
回答已采纳
发布于 2014-04-16 14:56:56
我觉得这应该能帮你找到你要去的地方。下面的代码将每个组保存为一个工作簿(.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 SubStack Overflow用户
发布于 2014-04-23 16:04:05
为了记录在案，这段代码在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页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/23106555
复制相关文章
相似问题
腾讯云开发者
