跨工作薄一对多表多值引用提取？

edm7321 · 发表于 2015-12-4 22:09

本帖最后由 edm7321 于 2015-12-4 22:10 编辑

“数据表”工作簿在当前目录，有名称为“表一”、“表二”、“表三”的工作表且结构相同。
要求：在“测试”工作簿中，在“证书编号：”输入，则获得“数据表”工作簿“表一”、“表二”、“表三”中的相应的数据。

aman1516 · 发表于 2015-12-4 23:23

本帖最后由 aman1516 于 2015-12-5 00:36 编辑

试试：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Object, sh As Worksheet, arr, krr, i, j, k, m, n, c, t
Application.ScreenUpdating = False
On Error Resume Next
If Target.Count > 1 Then Exit Sub
If Target.Column <> 2 And Target.Row < 2 Then Exit Sub
If Dir(ThisWorkbook.Path & "\数据表.xls") = "" Then
MsgBox ThisWorkbook.Path & "\AAA.xls 文件不存在，请确认并重新导出"
Exit Sub
End If
Set wb = GetObject(ThisWorkbook.Path & "\数据表.xls")
1 ReDim arr(1 To 1000, 1 To 11)
shn = Array("表一", "表二", "表三")
For i = 0 To UBound(shn)
With wb.Sheets(shn(i))
      r = .Range("C65536").End(xlUp).Row
      krr = .Range("A2:K" & r)
      For m = 1 To UBound(krr)
         k = k + 1
         For n = 1 To 11
               arr(k, n) = krr(m, n)
         Next
      Next
End With
Next
For q = 1 To k
If arr(q, 3) = Target.Value Then
   z = z + 1
   If z = 1 Then
      Target.Offset(0, 1) = arr(q, 4)
      Target.Offset(0, 2) = arr(q, 10)
      Target.Offset(0, 3) = arr(q, 11)
   Else
      Target.Offset(0, 1) = Target.Offset(0, 1) & "," & arr(q, 4)
      Target.Offset(0, 2) = Target.Offset(0, 2) & "," & arr(q, 10)
      Target.Offset(0, 3) = Target.Offset(0, 3) & "," & arr(q, 11)
   End If
End If
Next
Set wb2 = Nothing
Application.ScreenUpdating = True
End Sub

aman1516 · 发表于 2015-12-4 23:31

一对多跨工作薄引用.rar (18.88 KB, 下载次数: 30)

edm7321 · 发表于 2015-12-4 23:50

aman1516 发表于 2015-12-4 23:31

测试过了，主要功能达到，麻烦再解决下找到匹配条件的多个结果放在一个单元格里的问题。谢谢！

aman1516 · 发表于 2015-12-5 00:01

本帖最后由 aman1516 于 2015-12-5 00:34 编辑

这里改下：
For q = 1 To k
If arr(q, 3) = Target.Value Then
   z = z + 1
   If z = 1 Then
      Target.Offset(0, 1) = arr(q, 4)
      Target.Offset(0, 2) = arr(q, 10)
      Target.Offset(0, 3) = arr(q, 11)
   Else
      Target.Offset(0, 1) = Target.Offset(0, 1) & "," & arr(q, 4)
      Target.Offset(0, 2) = Target.Offset(0, 2) & "," & arr(q, 10)
      Target.Offset(0, 3) = Target.Offset(0, 3) & "," & arr(q, 11)
   End If
End If
Next

aman1516 · 发表于 2015-12-5 00:03

本帖最后由 aman1516 于 2015-12-5 00:37 编辑

edm7321 发表于 2015-12-4 23:50
测试过了，主要功能达到，麻烦再解决下找到匹配条件的多个结果放在一个单元格里的问题。谢谢！

表（2）一次性刷新的，同理自己改下即可：
Range("C2:E65536").ClearContents
For p = 2 To Range("B65536").End(xlUp).Row
z = 0
For q = 1 To k
      If Range("B" & p) = arr(q, 3) Then
         z = z + 1
         If z = 1 Then
            Range("C" & p) = arr(q, 4)
            Range("D" & p) = arr(q, 10)
            Range("E" & p) = arr(q, 11)
         Else
            Range("C" & p) = Range("C" & p) & "," & arr(q, 4)
            Range("D" & p) = Range("D" & p) & "," & arr(q, 10)
            Range("E" & p) = Range("E" & p) & "," & arr(q, 11)
         End If
      End If
Next
Next

edm7321 · 发表于 2015-12-5 00:14

本帖最后由 edm7321 于 2015-12-5 00:41 编辑

aman1516 发表于 2015-12-5 00:03
表（2）一次性刷新的，同理自己改下即可：
For p = 2 To Range("B65536").End(xlUp).Row
For q = 1 ...

老师，实在不好意思，我目前尚无修改的能力，有劳大师了。多个匹配值时出现死循环，不知怎么回事，我的2003版excel.

aman1516 · 发表于 2015-12-5 00:40

edm7321 发表于 2015-12-5 00:14
老师，实在不好意思，我目前尚无修改的能力，有劳大师了。

一对多跨工作薄引用.rar (21.2 KB, 下载次数: 46)

edm7321 · 发表于 2015-12-5 00:47

aman1516 发表于 2015-12-5 00:40

好啦，圆满解决，没有问题了。高手！！！热情！！！我非常感谢您。

会志 · 发表于 2023-6-2 09:15

请问老师，如何在“申请证书：”输入，则获得“数据表”工作簿“表一”、“表二”、“表三”中的相应的数据。代码应该怎样修改

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

[求助] 跨工作薄一对多表多值引用提取？

评分

评分

浏览过的版块