根据关键字是否相同提取数据到新表

hhxq001 · 发表于 2021-10-13 16:11

因为汇总表的各列字段名和分表的各列字段名不完全相同，并且列的顺序也是左右有变化，问下各位，能不能根据汇总表的列关键字从分表中提取需要列的数据？

求助-提取数据.zip (75.39 KB, 下载次数: 24)

吾股丰登 · 发表于 2021-10-13 17:47

PQ能够解决你的问题

limonet · 发表于 2021-10-13 18:10

PQ,OFFICE2016及以上版本支持刷新

hhxq001 · 发表于 2021-10-13 21:26

limonet 发表于 2021-10-13 18:10
PQ,OFFICE2016及以上版本支持刷新

讨教，PQ是何方神圣呢

limonet · 发表于 2021-10-13 22:16

hhxq001 发表于 2021-10-13 21:26
讨教，PQ是何方神圣呢

power query

hhxq001 · 发表于 2021-10-13 22:36

limonet 发表于 2021-10-13 22:16
power query

低版本没有吧，没找到呢？用代码不能解决吗

limonet · 发表于 2021-10-13 22:46

hhxq001 发表于 2021-10-13 22:36
低版本没有吧，没找到呢？用代码不能解决吗

Microsoft Office2016 (excel中自带。低版本的需要下载插件。）'用VBA复杂了

yanjie · 发表于 2021-10-13 22:57

我excel2010，没有这个功能，郁闷。

3190496160 · 发表于 2021-10-14 08:28

Sub 数据汇总()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
rs = .Cells(5, Columns.Count).End(xlToLeft).Column
   .Range(.Cells(6, 1), .Cells(r + 2, rs)) = Empty
If rs > 1 Then
      cr = .Range(.Cells(5, 1), .Cells(10000, rs))
      For j = 2 To UBound(cr, 2)
         If Trim(cr(1, j)) <> "" Then
            zf = Trim(cr(1, j))
            d(zf) = j
         End If
      Next j
End If
n = 1
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
      If f <> ThisWorkbook.Name Then
         Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
         ws = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
         ar = wb.Worksheets(1).Range("a1:ao" & ws)
         wb.Close False
         For i = 4 To UBound(ar)
            If Trim(ar(i, 3)) <> "" Then
                  n = n + 1
                  cr(n, 1) = n
                  For j = 1 To UBound(ar, 2)
                     If Trim(ar(3, j)) <> "" Then
                        lh = d(Trim(ar(3, j)))
                        If lh <> "" Then
                              cr(n, lh) = ar(i, j)
                        End If
                     End If
                  Next j
            End If
         Next i
      End If
f = Dir
Loop
.[a5].Resize(n, UBound(cr, 2)) = cr
End With
Application.ScreenUpdating = False
MsgBox "数据合并完毕!", 64, "提示"
End Sub

3190496160 · 发表于 2021-10-14 08:29

求助-提取数据.rar (105.38 KB, 下载次数: 58)

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

[求助] 根据关键字是否相同提取数据到新表