根据指定的表头文字复制相关列从其它文件里提取数据

hadky · 发表于 2024-9-17 13:02

本帖最后由 hadky 于 2024-9-17 17:12 编辑

这个宏适用于需要从多个源工作簿中提取特定数据并汇总到一个工作表中的情况。例如，当需要合并多个报表的数据或从不同的数据源中提取信息时，这个宏可以大大提高效率，减少手动操作的错误和时间消耗。

读取当前工作表的表头：
- 宏首先读取当前工作表的第一行，这些数据被视为表头。
打开文件选择对话框：
- 使用 FileDialog 对象打开文件选择对话框，让用户选择包含数据的源Excel工作簿。
打开源工作簿并获取第一个工作表：
- 根据用户选择的文件路径打开源工作簿，并获取其第一个工作表以进行数据匹配和复制操作。
匹配表头并记录匹配的列号：
- 遍历当前工作表的表头，在源工作表中查找匹配的表头。
- 如果找到匹配的表头，记录其在源工作表中的列号。
复制匹配列的数据：
- 对于每个匹配的列，复制源工作表中从第二行开始的数据（跳过表头），并将这些数据粘贴到当前工作表的相应列中的第一个空白行。
避免覆盖现有数据：
- 在粘贴数据之前，宏会找到目标列的第一个空白行，确保新数据不会覆盖现有数据。
关闭源工作簿：
- 操作完成后，关闭源工作簿，不保存更改。
  1. Sub CopyMatchingColumnsToCurrentSheet()
  2. Dim wsCurrent As Worksheet
  3. Dim wsSource As Worksheet
  4. Dim sourceWorkbook As Workbook
  5. Dim fileDialog As FileDialog
  6. Dim requiredHeaders As Variant
  7. Dim header As Variant
  8. Dim colSource As Long
  9. Dim matchingCols As Object
  10. Dim lastRow As Long
  11. Dim targetCol As Long
  12. Dim targetRow As Long
  13. Dim colKey As Variant
  15. ' 使用当前激活的工作表
  16. Set wsCurrent = ActiveSheet
  17. Set matchingCols = CreateObject("Scripting.Dictionary") ' 使用字典来存储匹配的列
  19. ' 读取当前工作表的所有表头
  20. requiredHeaders = wsCurrent.Rows(1).Value
  22. ' 创建文件对话框对象
  23. Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
  25. ' 让用户选择源工作簿
  26. With fileDialog
  27. .Title = "请选择源工作簿"
  28. .Filters.Clear
  29. .Filters.Add "Excel 文件", "*.xls; *.xlsx; *.xlsm; *.xlsb", 1
  30. .AllowMultiSelect = False
  31. If .Show = -1 Then
  32. ' 尝试打开选择的工作簿
  33. Set sourceWorkbook = Workbooks.Open(.SelectedItems(1))
  34. Else
  35. MsgBox "未选择任何工作簿。"
  36. Exit Sub
  37. End If
  38. End With
  40. ' 使用源工作簿的第一个工作表
  41. Set wsSource = sourceWorkbook.Sheets(1)
  43. ' 遍历当前工作表的每一列
  44. For Each header In requiredHeaders
  45. header = Trim(header) ' 清除可能的空白字符
  46. ' 检查源工作表的每一列表头
  47. For colSource = 1 To wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
  48. If LCase(wsSource.Cells(1, colSource).Value) = LCase(header) Then
  49. ' 如果找到匹配的表头，则记录列号
  50. matchingCols(header) = colSource
  51. Exit For
  52. End If
  53. Next colSource
  54. Next header
  56. ' 复制匹配的列
  57. For Each header In matchingCols.Keys
  58. colSource = matchingCols(header)
  59. lastRow = wsSource.Cells(wsSource.Rows.Count, colSource).End(xlUp).Row
  60. ' 找到目标列，粘贴数据
  61. targetCol = Application.Match(header, wsCurrent.Rows(1), 0)
  62. If Not IsError(targetCol) Then
  63. ' 找到第一个空白行
  64. targetRow = wsCurrent.Cells(wsCurrent.Rows.Count, targetCol).End(xlUp).Row + 1
  65. ' 仅复制数据，跳过表头
  66. wsSource.Range(wsSource.Cells(2, colSource), wsSource.Cells(lastRow, colSource)).Copy
  67. wsCurrent.Cells(targetRow, targetCol).PasteSpecial Paste:=xlPasteValues
  68. Application.CutCopyMode = False
  69. Else
  70. MsgBox "未找到匹配的表头: " & header
  71. End If
  72. Next header
  74. ' 关闭源工作簿，不保存更改
  75. sourceWorkbook.Close SaveChanges:=False
  77. ' 提示完成
  78. MsgBox "已根据指定的表头文字复制相关列。"
  79. End Sub
  复制代码
- 源表数据

ykcbf1100 · 发表于 2024-9-17 14:41

本帖最后由 ykcbf1100 于 2024-9-17 14:44 编辑

楼主上个附件呗
没用数组，效率不高。

xj123321 · 发表于 2024-9-19 10:36

支持一下。

Qs18 · 发表于 2024-9-19 11:21

Sub qs()
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim arr, i, wb As Workbook, xb As Workbook, FileName, brr, rw
Sheet1.Range("a1").Offset(1).Resize(50000, 20).Clear
brr = Sheet1.Range("a1").CurrentRegion.Value
Set wb = ThisWorkbook
'可多选文件对话框
FileName = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls*),*.xls*", Title:="请选择文件", MultiSelect:=True)
If Not IsArray(FileName) Then
MsgBox "没有选择文件"
Exit Sub
End If
With wb.Sheets(1)
For Each f In FileName '循环已经选了文件
rw = .Cells(Rows.Count, 1).End(3).Row + 1
Set xb = Workbooks.Open(f, 0)
arr = xb.Sheets(1).Range("a1").CurrentRegion
For b = 1 To UBound(brr, 2)
For a = 1 To UBound(arr, 2)
If brr(1, b) = arr(1, a) Then
.Cells(rw, b).Resize(UBound(arr), 1) = Application.Index(arr, 0, a)
Exit For
End If
Next a
Next b
xb.Close (0)
.Rows(rw).Delete
Next f
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True

复制代码

Qs18 · 发表于 2024-9-19 11:23

试试。。。。。。。。。。

Qs18 · 发表于 2024-9-19 11:24

试试........

hadky · 发表于 2024-9-19 20:54

确实效率和便捷性高多了

hadky · 发表于 2024-9-19 22:50

有一个问题是会清掉现有文档的存在记录，第二个是如果有去重的功能更好了

ykcbf1100 · 发表于 2024-9-20 09:16

hadky 发表于 2024-9-19 22:50
有一个问题是会清掉现有文档的存在记录，第二个是如果有去重的功能更好了

敢问一下，你这清除现有文档的存在记录，指的是源数据的工作表吗？
再问一下，你去重是按什么来去重的？去重后，日期肯定保留不了了，那还算按字段来提取数据吗？
本想下手了，但没搞清楚状况，不敢下手啊。

hadky · 发表于 2024-10-23 10:31

清除现有文档存在的记录，汇总表里原有的数据会清掉，
二个是，如果加载来源表里有重复的数据，应该是要去除的，应该把首列的头当做key

		自动登录	找回密码
密码			免费注册