将符合条件的两个表中的数据提取至一个表的指定位置

sunnyliner2018 · 发表于 2022-5-6 18:09

各位大神：
我需要将符合条件的两个表中的数据提取至一个表的指定位置，但是由于水平有限，不会同时将两个表的数据一并提取，只会将其中的一个表的数据进行提取。请各位大神帮忙。

Sub 匹配()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("DATA")
   ar = .[a1].CurrentRegion
End With
For i = 2 To UBound(ar)
   If Trim(ar(i, 1)) <> "" Then
      d(Trim(ar(i, 1))) = i
   End If
Next i
With Sheets("DATA2")
   ar = .[a1].CurrentRegion
End With
For i = 2 To UBound(ad)
   If Trim(ad(i, 1)) <> "" Then
      d(Trim(ad(i, 1))) = i
   End If
Next i
With Sheets("ZBTQ")
   rs = .Cells(Rows.Count, 1).End(xlUp).Row
   .Range("c2:e" & rs + 1) = Empty
   br = .Range("a1:f" & rs)
   For i = 2 To UBound(br)
      If Trim(br(i, 2)) <> "" Then
         xh = d(Trim(br(i, 2)))
         If xh <> "" Then
               br(i, 3) = Val(ar(xh, 3))
               br(i, 4) = Val(ar(xh, 4))
               br(i, 5) = ar(xh, 10)
               br(i, 3) = Val(ad(xh, 11))  '报错
               br(i, 4) = Val(ad(xh, 3)) '报错
               br(i, 5) = ad(xh, 6) '报错

         End If
      End If
   Next i
   .Range("a1:f" & rs) = br
End With
MsgBox "ok!"
End Sub

sunnyliner2018 · 发表于 2022-5-6 21:35

有没有在线的老师，有空帮忙看看。谢谢啦！

tel3033 · 发表于 2022-5-6 22:48

Sub cao()
Dim arr, brr, crr, d,i%
arr = Sheet2.[a1].CurrentRegion: brr = Sheet3.[a1].CurrentRegion
ReDim crr(1 To UBound(arr) + UBound(brr) - 2, 1 To 2)
For i = 2 To UBound(arr)
crr(i - 1, 1) = arr(i, 1)
crr(i - 1, 2) = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 10)
Next
For i = 2 To UBound(brr)
crr(UBound(arr) + i - 2, 1) = brr(i, 1)
crr(UBound(arr) + i - 2, 2) = brr(i, 11) & "|" & brr(i, 3) & "|" & brr(i, 6)
Next
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(crr)
d(crr(i, 1)) = crr(i, 2)
Next
With Sheet1
arr = .Range("b2:e" & .Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(arr)
arr(i, 2) = Val(Split(d(arr(i, 1)), "|")(0))
arr(i, 3) = Val(Split(d(arr(i, 1)), "|")(1))
arr(i, 4) = Val(Split(d(arr(i, 1)), "|")(2))
Next
[b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub

复制代码

tel3033 · 发表于 2022-5-6 22:52

sunnyliner2018 发表于 2022-5-6 21:35
有没有在线的老师，有空帮忙看看。谢谢啦！

代码审核中……

sunnyliner2018 · 发表于 2022-5-7 08:58

tel3033 发表于 2022-5-6 22:52
代码审核中……

老师：
早上好！
万分感谢有您。
这里我有一点不太明白，redim这里要-2,crr也是要-1， crr(UBound(arr) + i - 2
是因为有表头的原因吗，总共有二个表，所以要-2是这样理解吗。

ReDim crr(1 To UBound(arr) + UBound(brr) - 2, 1 To 2)
For i = 2 To UBound(arr)
      crr(i - 1, 1) = arr(i, 1)
      crr(i - 1, 2) = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 10)
Next
For i = 2 To UBound(brr)
      crr(UBound(arr) + i - 2, 1) = brr(i, 1)
      crr(UBound(arr) + i - 2, 2) = brr(i, 11) & "|" & brr(i, 3) & "|" & brr(i, 6)

tel3033 · 发表于 2022-5-7 10:09

sunnyliner2018 发表于 2022-5-6 21:35
有没有在线的老师，有空帮忙看看。谢谢啦！

重写了一下，感觉上一个有点繁琐。

Sub cao()
Dim arr, brr, d, i%, j%
arr = Sheet2.[a1].CurrentRegion: brr = Sheet3.[a1].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 10)
Next
For i = 2 To UBound(brr)
d(brr(i, 1)) = brr(i, 11) & "|" & brr(i, 3) & "|" & brr(i, 6)
Next
With Sheet1
arr = .Range("b2:e" & .Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(arr)
For j = 0 To 2
arr(i, j + 2) = Val(Split(d(arr(i, 1)), "|")(j))
Next
Next
[b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub

复制代码

tel3033 · 发表于 2022-5-7 10:11

本帖最后由 tel3033 于 2022-5-7 10:56 编辑

第2种

Sub cao()
Dim arr, brr, d, i%, j%
arr = Sheet2.[a1].CurrentRegion: brr = Sheet3.[a1].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr) + UBound(brr) - 1
j = UBound(arr)
If i <= j Then
d(arr(i, 1)) = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 10)
Else
d(brr(i - j + 1, 1)) = brr(i - j + 1, 11) & "|" & brr(i - j + 1, 3) & "|" & brr(i - j + 1, 6)
End If
Next
With Sheet1
arr = .Range("b2:e" & .Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(arr)
For j = 0 To 2
arr(i, j + 2) = Val(Split(d(arr(i, 1)), "|")(j))
Next
Next
[b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub

复制代码

sunnyliner2018 · 发表于 2022-5-7 11:11

tel3033 发表于 2022-5-7 10:09
重写了一下，感觉上一个有点繁琐。

调用数据.7z
老师，
我用自已的模板修改出现了错误。提示“下界超标”，您有时间帮我看一下。
Sub cao2()
Dim arr, brr, d, i, j%
arr = Sheets("数据源-料件").[a2].CurrentRegion: brr = Sheets("数据源-成品").[a5].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
      d(arr(i, 2)) = arr(i, 3) & "|" & arr(i, 9) & "|" & arr(i, 2)
Next
For i = 6 To UBound(brr)
      d(brr(i, 10)) = brr(i, 2) & "|" & brr(i, 5) & "|" & brr(i, 16)
Next
With Sheets("库存")
      arr = .Range("b2:ao" & .Cells(Rows.Count, 2).End(xlUp).Row)
      For i = 3 To UBound(arr)
         For j = 0 To 2
            arr(i, j + 2) = Val(Split(d(arr(i, 1)), "|")(j))
         Next
      Next
      [b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub

tel3033 · 发表于 2022-5-7 11:20

sunnyliner2018 发表于 2022-5-7 08:58
老师：
早上好！
万分感谢有您。

ReDim crr(1 To UBound(arr) + UBound(brr) - 2, 1 To 2)
arr和brr各减去了一个标题行，所以减2
新建的crr没考虑设标题行，循环是从2开始的，要将数据写在第一行，所以2-1=1

sunnyliner2018 · 发表于 2022-5-7 12:12

tel3033 发表于 2022-5-7 11:20
ReDim crr(1 To UBound(arr) + UBound(brr) - 2, 1 To 2)
arr和brr各减去了一个标题行，所以减2
新建的 ...

老师：
如果我再增加一个关键值的情况下，会提示报错。

副本数据提取.7z
Sub cao22()
Dim arr, brr, d, i%, j%
arr = Sheet2.[a1].CurrentRegion: brr = Sheet3.[a1].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
      d(arr(i, 1) & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 10)
      '把关键值从第1列改为2列

Next

For i = 2 To UBound(brr)
      d(brr(i, 1) & brr(i, 12)) = brr(i, 11) & "|" & brr(i, 3) & "|" & brr(i, 6)
      '把关键值从第1列改为2列
Next
With Sheet1
      arr = .Range("a2:o" & .Cells(Rows.Count, 1).End(xlUp).Row)
      For i = 1 To UBound(arr)
         For j = 0 To 2
            arr(i, j + 10) = Split(d(arr(i, 8) & arr(i, 9)), "|")(j)
            '把关键值从第1列改为2列
         Next
      Next
'       [b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
      Sheets("ZBTQ").Range("a2:o" & UBound(arr)) = arr
End With
End Sub

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

[求助] 将符合条件的两个表中的数据提取至一个表的指定位置

评分

评分

评分

评分