将Excel工作簿拆分为单独的文件,然后根据唯一列保存在单独的文件夹中 [英] split Excel workbooks into separate file and then save in separate folders based on unique column
问题描述
我试图将一个带有多个工作表的excel文件拆分为单独的文件,然后根据唯一列将它们保存在单独的文件夹中.
I am trying to split one excel file with multiple worksheets into separate file and then save them in separate folders based on a unique column.
因此,每个工作表的A列都标记为"AgencyName".大约有80家代理商.对于所有这些机构,我在一个文件中有80个工作表.
So column A of each worksheet is labelled "AgencyName". There are about 80 agencies. I have 80 worksheets in one file for all these agencies.
目标:使用"A列"作为文件名拆分这些文件,然后将它们保存在以每个代理商命名的文件夹中.
Goal: To split these files using Column A as the file name and then save them in a folder that are named after each agency.
例如:该机构的名称是底特律".我有一个底特律"工作表和一个名称完全相同的文件夹.我想将此工作表另存为底特律文件夹下的单独文件.
For example: of the agency is "Detroit". I have a worksheet for "Detroit" and a folder named exactly the same. I want to save this worksheet as a separate file under the Detroit Folder.
任何帮助将不胜感激.
推荐答案
以下宏会将每个工作表另存为新工作簿中的单个工作表:
The following macro will save each worksheet as the single worksheet in a new workbook:
Option Explicit
Public Sub SplitFile()
Const dstTopLevelPath As String = "C:\MyData\AgencyStuff"
Dim dstFolder As String
Dim dstFilename As String
Dim dstWB As Workbook
Dim dstWS As Worksheet
Dim srcWB As Workbook
Dim srcWS As Worksheet
Dim Agency As String
'Ensure the destination path exists
If Dir(dstTopLevelPath, vbDirectory) = "" Then
MsgBox dstTopLevelPath & " doesn't exist - please create it before running this macro"
End
End If
Set srcWB = ActiveWorkbook
For Each srcWS In srcWB.Worksheets
'Get the Agency name
'(use this line if the Agency name is in cell A2 of each worksheet)
Agency = srcWS.Range("A2").Value
'(use this line if the Agency name is the actual worksheet name)
'Agency = srcWS.Name
'Create the destination path
dstFolder = dstTopLevelPath & "\" & Agency
'Create the destination file name
'(use this line if you want the new workbooks to have a name equal to the agency name)
dstFilename = dstFolder & "\" & Agency & ".xlsx"
'(use this line if you want the new workbooks to have the same name as your existing workbook)
'(Note: If your existing workbook is called "xyz.xlsm", the new workbooks will have a ".xlsm"
' extension, even though there won't be any macros in them.)
'dstFilename = dstFolder & "\" & srcWB.Name
'(use this line if you want the new workbooks to have a fixed name)
'dstFilename = dstFolder & "\data.xlsx"
'Create a new workbook
Set dstWB = Workbooks.Add
'Copy the current sheet to the new workbook
srcWS.Copy Before:=dstWB.Sheets(1)
'Get rid of any sheets automatically created in the new workbook ("Sheet1", "Sheet2", etc)
For Each dstWS In dstWB.Worksheets
If dstWS.Name <> srcWS.Name Then
Application.DisplayAlerts = False
dstWS.Delete
Application.DisplayAlerts = True
End If
Next
'Ensure the new location exists, and create it if it doesn't
If Dir(dstFolder, vbDirectory) = "" Then
MkDir dstFolder
End If
'Save the new workbook to the required location
dstWB.SaveAs dstFilename
'Close the new workbook
dstWB.Close
Next
MsgBox "Finished"
End Sub
(这假设您的源工作表均未包含"Sheet1","Sheet2"等名称)
(This assumes that none of your source worksheets have names such as "Sheet1", "Sheet2", etc.)
这篇关于将Excel工作簿拆分为单独的文件,然后根据唯一列保存在单独的文件夹中的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!