在Excel中将文件拆分成多个文件 [英] Split file into multiple files in Excel
问题描述
我在Excel中有以下文件:
I have the following file in Excel:
NAME VALUE
ABC 10
ABC 11
ABC 12
DEF 20
DEF 21
DEF 22
GHI 30
GHI 31
GHI 32
我想通过名称列(上面的示例的3个文件)将其拆分为文件:
I'd like to split it into files by the 'Name' column (3 files for the example above) as following:
文件: 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
到目前为止,尝试了以下宏:
< a href =https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-wbs =nofollow> https://sites.google.com/ A / madrocketsc ientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-wbs
So far, tried the following macro: https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-wbs
在此行上有运行时错误 ws。范围(vTitles).AutoFilter
注释后,将错误移动到 ws.Range(vTitles).AutoFilter字段:= vCol,Criteria1:= MyArr当$ code> vCol
的值变为空时,
Got runtime errors on this line ws.Range(vTitles).AutoFilter
And after commenting it out the error moved to ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
when vCol
's value became empty.
我做错了什么请? (因为VBA不是我的最强点atm)。关于上面的代码片段的任何建议或者替代代码可以为我做一个可行的解决方案。
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.
推荐答案
我认为这应该是让你去哪里以下代码将每个组作为工作簿(.xls格式)与容纳VBA的工作簿(即 ThisWorkbook
)在同一目录中保存:
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
):
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
这篇关于在Excel中将文件拆分成多个文件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!