如何根据列中的值将数据导出到单独的工作簿中

经过John Macdougall.



2017-05-07



VBA

在任何类型的工作中都会反复出现的东西是根据字段的值将数据分离到单独的工作簿中的数据。

下载示例文件

假设您对贵公司有销售数据，您需要在公司中发送每个销售代表的销售副本。您可能不希望通过每个代表分享整套数据，但仅仅是由于委员会的委员会周围的隐私问题所致的销售。为此，我们需要使用原始数据集，并根据数据中的销售代表列，将其解析为许多不同的工作簿（每个销售代表一个）。

将数据解析为不同的工作簿是一个非常常见的问题，但不幸的是Excel没有内置的解决方案．我们需要手动过滤列中的每个项，然后将过滤后的数据复制并粘贴到一个新文件中并保存。如果我们有很多值需要过滤，或者这是一个我们每月、每周甚至每天都要做的活动，那么这可能会非常耗费时间。幸运的是,我们可以用VBA实现自动化！！

这个模板允许您通过选择一列来分离数据。此工作簿使用名为数据保存汇总数据。您可以调整大小和列标题以适合您的数据。删除或添加列根据需要和重命名列标题以适应您自己的数据。下拉菜单将自动说明新的列标题。相应地设置你的保存路径，这是VBA将保存它创建的所有新数据文件的地方。模板设置好后，按下跑步按钮和您的新数据文件将显示在“保存路径”文件夹中。

VBA使用命名范围引用，所以模板是灵活的，你可以剪切和粘贴工作表，直到你满意，你不会破坏代码。下面是模板中使用的VBA代码。

选项显式子ExportData()'Declare variables Dim ArrayItem As Long Dim ws As Worksheet Dim ArrayOfUniqueValues As Variant Dim SavePath As String Dim ColumnHeadingInt As Long Dim ColumnHeadingStr As String Dim rng As Range '设置工作表设置ws = Sheets("Data")设置文件的保存路径SavePath = Range("FolderPath")'根据ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria"))为想要分离数据的列设置变量。Value, Range("Data[#Headers]")， 0) ColumnHeadingStr = "Data[[#All]，[" & Range("ExportCriteria")。'关闭屏幕更新以保存运行时应用程序。ScreenUpdating = False'Create a temporary list of unique values from the column we want to 'separate our data based on Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Range("UniqueValues"), Unique:=True 'Sort our temporary list of unique values ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _ Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 'Add unique field values into an array 'ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("IV2:IV" & Rows.Count).SpecialCells(xlCellTypeConstants)) ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants)) 'Delete the temporary values ws.Range("UniqueValues").EntireColumn.Clear 'Loop through our array of unique field values, copy paste into new workbooks and save For ArrayItem = 1 To UBound(ArrayOfUniqueValues) ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem) ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy Workbooks.Add Range("A1").PasteSpecial xlPasteAll ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), " YYYY-MM-DD hhmmss") & ".xlsx", 51 ActiveWorkbook.Close False ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt Next ArrayItem ws.AutoFilterMode = False MsgBox "Finished exporting!" Application.ScreenUpdating = True End Sub

笔记:这是被测试的Excel 2016.但我没有在以前的版本上测试它。

关于作者

John Macdougall.

John是一个微软MVP和自由职业顾问和专业从事Excel，Power BI，Power自动化，电源应用程序和SharePoint的培训师。您可以在博客或YouTube频道上找到其他有趣的文章。

删除不需要的空间字符的4种方法

2018年9月27日

学习如何使用各种方法从Excel中的文本数据中删除不需要的空格字符。

如何自动排序，隐藏，取消隐藏和列出你的表

2018年4月1日

通常情况下，工作簿会变得非常大，最后会有很多……

如何从列表中创建、删除和重命名文件夹

2018年2月4日

我开始制作视频与我的帖子一起参加枢轴表101 ...

16评论

Prabhas. 2017-05-26在06:23

这个工具真的很好。我想建议的一件事是输出输出可以设置“自动适应列宽度”。
回复
- 约翰 2017-05-26, 07:43
  
  好建议。我会试着在接下来的几天里补充这一点。
  回复
  - Shabbir. 2017-07-01 01:07
    
    如果要创建的文件名已经存在呢?这将有助于独特性:
    ActiveWorkbook。保存As SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), ” YYYY-MM-DD hhmmss”) & “.xlsx”, 51
    (我是VBA新手)
    回复
    - 约翰 2017-07-01 10:24
      
      是的，文件名上的时间戳是一个很好的主意，并会阻止重复。我的解决方案目前将覆盖已存在的任何文件。
      回复
  - Lou-Ellen 2018-05-10 22:16
    
    嗨John - 什么是真棒的工具！非常感谢分享。您是否有如何使输出设置为自动专用列宽的VBA脚本？谢了哥们！
    回复
拉您正在 2018-03-31在23:32

2018年4月1日12:38
大家好，

我有一个主文件的标题如下

没有
项
价钱
数量
全部的
分散式
任务1
Task2.
任务3.
任务4.
完全的
合并
评论
团队成员

团队负责人在前3列中输入数据，并选择要为第14列的任务提供的团队成员的名称。

然后他运行宏ExportByName，如果新工作簿已经存在，就会创建它们，然后添加到文件的末尾。

小组成员完成任务并填写Task1, Task2, Task3, Task4栏，然后填写完成日期。

当团队负责人运行以下宏时

子BrildInAllCompletedData（）
调用sortallfiles.
叫LoopThroughDirectory
叫UpdateDateInSheet1ColK
呼叫updateoriginaldata.
呼叫clearsheet1.
结束子

所有完成的工作都得到了巩固。

[代码]

子ExportByName ()
暗淡唯一（1000）作为字符串
DIM WB（1000）作为工作簿
暗淡的ws作为工作表
暗淡x只有
昏暗如长
尽可能多的昏暗
Dim uCol As Long

在错误GoTo ErrHandler

应用程序。ScreenUpdating = False
应用程序。计算= xlCalculationManual
应用程序。DisplayAlerts = False

你的主要工作表信息。
设置WS = ActiveWorkBook.sheets（“OriginalData”）

让uCol = 14 '列O

让Strt = ws.Cells(ws.Rows. rows . cells . cells)统计,6)指标(xlUp)。最终行+ 1: Stp = ws.Cells(ws.Rows.Count, uCol).End

(xlUp)。行

让ws。范围(“F”& Strt &“:F”& Stp &“”)。价值= Format(Date, “dd/mmm/yyyy”) ‘ adding the dates to the new rows

让ws。Range(“A” & Strt & “:A” & Stp & “”).Value = Application.Evaluate(“=row(” & Strt & “:” & Stp & “)-1”) ‘ adding the S.no. to

新行

ct = 0.

For x = 2 To ws.Cells(ws.Rows. cells .)统计,uCol)指标(xlUp) .Row最终
如果countifArray（activeSheet.Cells（x，ucl），uind（））= 0则为0
唯一（CT）= ActiveSheet.Cells（x，ucl）.text
CT = CT + 1
如果
下X.

For x = 0 To ws.Cells(ws.Rows. cells .)统计,uCol)指标(xlUp) .Row最终– 1
如果唯一（x）“”那么
如果Dir (ThisWorkbook。路径和“\”& unique(x) & “.xlsx”, vbNormal) = “” Then ‘If unique file does not exist

工作簿.ADD.: Set wb(x) = ActiveWorkbook
ws.range（ws.cells（1,1），ws.cells（1，ucl））。复制WB（x）。表格（1）.cells（1,1）
其他的
工作簿。打开文件名:= ThisWorkbook。路径和“\”& unique(x) & “.xlsx”
设置WB（x）= ActiveWorkBook
如果

For y = Strt To Stp
如果ws。Cells(y, uCol) = unique(x
ws.range（ws.cells（y，1），ws.cells（y，ucl））。复制
WB（x）.sheets（1）.cells（worksheetfunction.counta（wb（x）。表格（1）.columns（ucl））+ 1,1）.pasteSpecial

粘贴:= xlPasteValuesAndNumberFormats
如果
下一个Y.
“最适合的
世行(x) .Sheets (1) .Columns.AutoFit
WB（x）.saveas thewworkbook.path＆“\”＆unique（x）＆“.xlsx”，fileformat：= xlopenxmlworkbook，createbackup：= false
世行(x)。关闭保存Changes:=True
其他的
'quit循环
退出
如果
下X.

application.displayalerts = true
应用程序。ScreenUpdating = True
应用程序。计算= xlCalculationAutomatic

errhandler：
application.displayalerts = true
应用程序。ScreenUpdating = True
应用程序。计算= xlCalculationAutomatic

结束子

公共函数CountIfArray(lookup_value作为字符串，lookup_array作为变量)
countifarray = application.count（application.match（lookup_value，lookup_array，0）））
结束函数

子BrildInAllCompletedData（）
调用sortallfiles.
叫LoopThroughDirectory
叫UpdateDateInSheet1ColK
呼叫updateoriginaldata.
呼叫clearsheet1.
结束子

'https://www.mrexcel.com/forum/excel-questions/471802- vba-open-file-run-code-close-save-open-next-file.html.
sub sortallfiles（）
暗帧dath作为字符串
将暗中文件命名为字符串
Dim WB作为工作簿

应用程序。DisplayAlerts = False

folderpath = ActionWorkBook.Path＆“\”'更改为适合
如果右（folderpath，1）“\”那么foldpath = foldpath +“\”
文件名= Dir(folderPath & " *.xlsx ")
当文件名" "
应用程序。ScreenUpdating = False
设置wb =工作簿。打开(folderPath &文件名)
“请在此处调用子程序以刚刚打开的工作簿运行
如果filename =“zmaster.xlsm”那么
退出子
其他的
调用sortsheet1inallfiles.
如果
filename = dir.
循环
应用程序。ScreenUpdating = True
application.displayalerts = true
结束子

Sub sortsheet1inallfiles（）
将myfile暗中作为字符串
昏暗的erow
昏暗行合并为长
昏暗的绘光圈
Dim i As Long

eRow =表(“Sheet1”).Cells(行。计数,1)指标(xlUp)最终。抵消(1,0).Row

细胞。选择
ActiveWorkBook.Worksheets（“Sheet1”）。sort.sortfields.clear
ActiveWorkBook.WorkSheets（“Sheet1”）。sort.sortfields.add键：=范围（“k2：k”和erow）_
， SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
与ActiveWorkbook.Worksheets .Sort(“Sheet1”)
.SetRange Range(" A1:N " & eRow)
.header = xlyes.
.matchcase = false.
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
。申请
结束
ActiveWorkbook。保存
范围（“A1”）。选择
ActiveWorkbook。关闭

结束子

“http://www.exceltrainingvideos.com/transfer-data-multiple-workbooks-master-workbook-automatically/

子跟踪程度（）
将myfile暗中作为字符串
昏暗的erow
昏暗的lrl
昏暗的lrk只有
Dim i As Long

Dim FilePath为字符串
FilePath = ActiveWorkbook。路径和“\”

应用程序。DisplayAlerts = False
应用程序。ScreenUpdating = False
床单（“表格1”）。激活
MyFile = Dir (FilePath)
做While Len(MyFile) > 0
如果MyFile = " zmaster. txt "xlsm”然后
退出子
如果

工作簿。打开(FilePath & MyFile)
lrk = cells（rows.count，11）.end（xlup）.offset（1,0）.row'l列l
lrl = cells（rows.count，12）.end（xlup）.offset（1,0）.row'列k

对于i = lrl到lrk
范围（“A”＆LRL＆“：”＆“k”＆lrk）.copy
下一个
ActiveWorkbook。关闭

Erow = Sheet1.Cells（Rows.count，1）.end（xlup）.offset（1,0）.row
ActiveSheet.paste.Destination:=Worksheets(“Sheet1”).Range(Cells(eRow, 1), Cells(eRow, 11))

如果MyFile = " zmaster. txt "xlsm”然后
退出子
如果

工作簿。打开(FilePath & MyFile)
For i = LRL To LRK - 1
如果Range(" L " & i).Value = " "则
范围（“l”＆i）.value =日期
列（“L：L”）。NumberFormat =“$ -C09] DD-MMM-yy; @”
如果
下一个
范围（“A1”）。选择
ActiveWorkbook。保存
ActiveWorkbook。关闭

myfile = dir.
ActiveWorkbook。保存
循环

列（“A：D”）。选择
ActiveWorkBook.Worksheets（“Sheet1”）。sort.sortfields.clear
ActiveWorkbook.Worksheets .Sort.SortFields(“Sheet1”)。Add Key:=Range(" A2:A " & eRow) _
， SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
与ActiveWorkbook.Worksheets .Sort(“Sheet1”)
.setrange范围（“A1：D”和Erow）
.header = xlyes.
.matchcase = false.
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
。申请
结束

应用程序。ScreenUpdating = True
application.displayalerts = true
结束子

子UpdateDateInSheet1ColK ()
昏暗的erow
Dim i As Long

床单（“表格1”）。激活
eRow =表(“Sheet1”).Cells(行。计数,1)指标(xlUp)最终。抵消(1,0).Row
For i = 2 To eRow
If Range(" K " & " i ") " " Then
Range(" L " & i).Value = Format(日期，" dd/mmm/yyyy ")
如果
下一个
结束子

'https://www.youtube.com/watch?v=azhq5kinybk.
子UpdateOriginalData ()
Dim i As Integer
将暗j为整数
Dim LastRow1为整数
Dim LastRow2为整数
昏暗的sno作为双倍

LastRow1 =表格（“Sheet1”）。范围（“A”＆Rows.count）.end（xlup）.row
LastRow2 =表(“OriginalData”)。范围(“A”& Rows.Count)指标(xlUp) .Row最终

对于i = 2到lastrow1
SNo =表(“Sheet1”)。细胞(我,“一个”)。价值
床单（“原始数据”）。激活
For j = 2 To LastRow2
如果表(“OriginalData”)。细胞(j,“A”)。价值= SNo Then
床单（“表格1”）。激活
表(“Sheet1”)。范围(单元格(i，“G”)，单元格(i，“L”))。复制
床单（“原始数据”）。激活
表(“OriginalData”)。范围(单元格(j，“G”)，单元格(j，“L”))。选择
ActiveSheet.paste.
如果
接下来J.
application.copopymode = false.
接下来我
床单（“原始数据”）。激活
细胞。选择
ActiveWorkbook。保存
selection.columns.autofit.
范围（“A1”）。选择

结束子

子ClearSheet1 ()
昏暗的erow

床单（“表格1”）。激活
eRow =表(“Sheet1”).Cells(行。计数,1)指标(xlUp)最终。抵消(1,0).Row

范围(“A2: O”& eRow)。选择
选择.ClearContents.
selection.columns.autofit.
范围（“A1”）。选择
ActiveWorkbook。保存
结束子
(/代码)

这是一个完整的项目，我在工作中使用它。

我能做到这一点，主要要感谢宗师迪内什·库马尔·塔基亚。

问候

拉您正在
回复
菲利普hardcastle 2018-06-13 19:34

嗨，约翰，

我是excel vba的新手，需要在你的代码上有一点帮助。我需要确切地做你在描述的内容。我知道足以理解它的大部分，但在它中，您参考以下内容：

ColumnHeadingInt = WorksheetFunction.Match(范围(“ExportCriteria”)。值,范围(“星期(# header)”),0)
columnheadingstr =“distribution_template [[##全部]，[”和范围（“ExportCriteria”）。值＆“”]“

代码给我一个对象'_worksheet'失败的运行时错误（1004）的方法'范围'。这可能是因为我不明白代码中的“exportCriteria”和“数据[#Headers]”意味着什么。它们没有定义。你能解释一下吗？
回复
- 约翰 2018-06-27 18:06
  
  ExportCriteria是电子表格模板中的一个命名范围。您可以使用Excel中的名称框导航到它并确认它存在(可能您不小心删除了它)。
  
  数据[#headers]是表格参考。有一个名为数据的表，我们正在引用表的列标题部分。
  回复
比恩卡 2019-02-20 11:57

嗨，约翰，

这是一个非常棒的模板!然而，我想知道是否有一种方法复制和粘贴作为一个表而不是值?我没有试着去操作代码，但我还没弄明白。
回复
伊莱恩 2019-03-14在13:42

嗨，我无法下载Example文件
回复
- 约翰 2019-03-14在14:23
  
  我刚测试过。工作很好。点击橙色按钮，然后点击右上角的下载图标。
  回复
andrea 2019-05-13 18:39

嗨约翰，非常感谢你这个模板！它很棒!!
您会建议我如何编辑代码，而不是选择所有过滤的行，它将只选择前25行(附加到标题)?
回复
- 约翰 2019-05-22 15:10
  
  基于这段代码的工作方式，没有办法修改它来实现这一点。Excel没有筛选前N项的选项。
  
  如果向数据中添加一列，该列是该字段中每个唯一项的索引，则可以在索引>= 25上添加一个条件筛选器。
  
  WS.ListObjects（“数据”）。Range.AutoFilter字段：= ColumnHeadingint，Criteria1：= ArrayoFunqueValues（ArrayItem）
  
  您需要相应地修改上面的代码行Criteria2．好运！
  回复
克里希纳 2020-01-10 08:17

我使用的导出条件列不应该出现在宏创建的文件中。你能帮我一下吗?
回复
杰夫C 2020年1月21日16:03

这解决了我的挑战-现在如果他们给我加薪，哈哈。谢谢你,约翰!
回复
威廉。史密斯在15:57的2020-02-02

嗨John，我留下了关于添加代码的早期消息，这些代码将从源工作表（“数据”）从源工作表（“数据”）复制到新工作簿。如果我还评论了从源工作簿中复制两个支持工作表的需要，我不会记得。我知道复制工作表有许多示例，因此诀窍将包括宏中的所需代码。我假设纠正部分是：

'循环通过我们的唯一字段值，将粘贴复制到新工作簿并保存
for arrayitem = 1到ubound（arrayofunquevalues）
WS.ListObjects（“数据”）。Range.AutoFilter字段：= ColumnHeadingint，Criteria1：= ArrayoFunqueValues（ArrayItem）
ws.Range(“数据[#]”).SpecialCells .Copy (xlCellTypeVisible)
工作簿.ADD.
范围(" A1 ")。PasteSpecial xlPasteAll
ActiveWorkbook。保存As SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), ” YYYY-MM-DD hhmmss”) & “.xlsx”, 51
ActiveWorkBook.Close False.
WS.ListObjects（“数据”）。Range.AutoFilter字段：= ColumnHeadingint
下一个ArrayItem.

我还需要设置ws = Sheets(" Data ")，以包括额外的表，因此:

设置WS =表格（“数据”，“列表”，“FX”）

如果我正确地阅读了代码，我不认为包括其他工作表将干扰代码的执行方式。我只需要添加代码来复制其他工作表。
回复