主工作簿提取目录下相应其他工作簿中符合条件的数据

zhyoli · 发表于 2020-3-10 10:47

本帖最后由 zhyoli 于 2020-3-10 10:48 编辑

工作当中遇到一个问题，有5张表需要从核心系统导出来然后汇总到一张表。
主表是设计好的报表格式，现在需要从导出的其他5张单一指标工作簿中提取相应数据到主表。用vba或者相关函数实现怎么做？

大神们帮忙解决下。我把表整理了一下详见附件。
附件压缩包里一个主表两张取数表。

汇总统计.rar (25.97 KB, 下载次数: 8)

abc123281 · 发表于 2020-3-10 11:03

都已经注册论坛12年了，只会等着索要答案吗

zhyoli · 发表于 2020-3-10 11:08

求帮助！

opel-wong · 发表于 2020-3-10 11:10

你提取哪个月份的数据？
一月份还是三月份？

zhyoli · 发表于 2020-3-10 11:19

opel-wong 发表于 2020-3-10 11:10
你提取哪个月份的数据？
一月份还是三月份？

暂时提取的是3月的数据，下个月就提取4月的数据。那个1月不用管他。

opel-wong · 发表于 2020-3-10 11:54

zhyoli 发表于 2020-3-10 11:19
暂时提取的是3月的数据，下个月就提取4月的数据。那个1月不用管他。

给你做了一个微信银行的，如下图所示，
其余的，你以葫芦画瓢吧，

opel-wong · 发表于 2020-3-10 11:55

以提取微信银行的数据为例，代码如下：

Sub 自动取数()
Dim arr, i As Long, wb As Workbook, mFile As String, mRow As Long, mStr As String, mKeys, key
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
mFile = ThisWorkbook.Path & "\\2020年考核_微信银行注册绑卡用户数表.xlsx"
Set wb = GetObject(mFile)
With wb
With .Worksheets(1)
mRow = .Range("J1000").End(3).Row
arr = .Range("J5:W" & mRow).Value
End With
.Close False
End With
For i = 1 To UBound(arr)
If Len(arr(i, 1)) > 0 And Not d.Exists(arr(i, 1)) Then d(arr(i, 1)) = Val(arr(i, 5))
Next
mKeys = d.keys
With ThisWorkbook.Worksheets("Sheet1")
.Activate
mRow = .Range("A1000").End(3).Row
arr = .Range("A5:W" & mRow).Value
For i = 1 To UBound(arr)
For Each key In mKeys
If InStr(key, arr(i, 1)) Then arr(i, 7) = d(key)
Next
Next
.Range("A5:W" & mRow).Value = arr
End With
Set d = Nothing
End Sub

复制代码

3190496160 · 发表于 2020-3-10 13:12

Sub test()
Set sh = ThisWorkbook.Worksheets(1)
m = Val(Left(sh.[a1], 3))
ar = sh.Range("a3:x23")
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
      If InStr(wb.Name, "微信") > 0 Then
         y = 7
      ElseIf InStr(wb.Name, "手机银行") > 0 Then
         y = 10
      End If
      br = wb.Worksheets(1).UsedRange
      For i = 5 To UBound(br)
         For s = 3 To UBound(ar)
            If Trim(ar(s, 1)) <> "" Then
                  If InStr(br(i, 10), ar(s, 1)) > 0 Then
                     ar(s, y) = br(i, m + 11)
                  End If
            End If
         Next s
      Next i
      wb.Close False
End If
f = Dir
Loop
sh.Range("a3:x23") = ar
End Sub

3190496160 · 发表于 2020-3-10 13:13

代码仅仅针对你上传的附件，其他的，自己一样画葫芦吧

汇总统计.rar (36.73 KB, 下载次数: 4)

zhyoli · 发表于 2020-3-10 16:15

3190496160 发表于 2020-3-10 13:13
代码仅仅针对你上传的附件，其他的，自己一样画葫芦吧

谢谢了，就是这样的效果。我研究一下代码，注册论坛时间很长了。可是中间一段时间好长时间不从事这方面的工作了。现在又开始做这样的工作，对Vba生疏了。加你QQ了，有机会还要向你请教。

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

[求助] 主工作簿提取目录下相应其他工作簿中符合条件的数据

最新热点 /1

[求助] 主工作簿 提取 目录下相应 其他工作簿中符合条件的数据

最新热点 /1

[求助] 主工作簿提取目录下相应其他工作簿中符合条件的数据