跨欄對比

198188

下載 (48.9 KB)

2024-3-2 12:21

有三個表格，在表格“1”執行，
表格“1” 欄B 和欄G 兩樣分別在表格“KP" & "KH" 找尋，如果找到相同的數據。

舉例：
96089 & 5580 組合在KP 表裏找到
“1”表的欄M (Project) 傳回"KP"表的 "$A$1"
“1”表的欄O (KP) 傳回"KP"表的 "$C$1"

96183 & 4780 組合在 KP & KH 表裏都找到
"1”表的欄M (Project) 傳回"KP"表的 "$H$1" & "KH" 表的“$H$1", 兩者都是"BH" 相同，所以顯示"BH"
"1”表的欄N (KH) 傳回"KH"表的 "$J$1"
"1”表的欄O (KP) 傳回"KP"表的 "$J$1"

94851 & 5370 組合在 KH 表裏都找到
"1”表的欄M (Project) 傳回"KH"表的 "$A$1" &  "$H$1", 兩者不 相同，所以顯示"BF/BH"
"1”表的欄N (KH) 傳回"KH"表的 "$C$1" &  "$J$1", 兩者都是“噴油”相同，所以顯示“噴油”

96093 & 5260 組合在 KH & KP表裏都找到
"1”表的欄M (Project) 傳回"KP"表的"$A$1" & "$H$1" & "KH" 表的"$A$1" & "$H$1", 四都是"BF/ BH/ BF/ BH" 相同，因爲重複，所以顯示"BF/ BH"
"1”表的欄N (KH) 傳回"KH"表的 "$C$1" &  "$J$1", 兩者都是“噴油”相同，所以顯示“噴油”
"1”表的欄O (KP) 傳回"KP"表的  "$C$1" &  "$J$1", 兩者都是“噴油”相同，所以顯示“噴油”

198188

下載 (93.37 KB)

2024-3-4 11:34

回復 1# 198188


    圖片是執行前及執行后效果，以及兩個資料庫 KP & KH。

Andy2483

回復 2# 198188


    謝謝前輩發表此主題與範例
請問[M5]裡的 BF/BH/BJ  ,這 BJ從何來?

198188

回復 3# Andy2483


    KH 資料表的 H1 儲存格

Andy2483

回復 1# 198188


Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, V$, Z, i&, T$, TT$, A, xA As Range, N%
Set Z = CreateObject("Scripting.Dictionary")
Set xA = Range([1!G1], [1!A65536].End(3))
xA.Offset(1, 12).ClearContents:  Brr = xA
For i = 2 To UBound(Brr)
   T = Format(Trim(Brr(i, 2)), "0000000"): V = Format(Val(Brr(i, 7)), "0000000"): TT = T & "/" & V
   Z(TT) = i
Next
Arr = [1!M1].Resize(UBound(Brr), 3)
A = Array(Range([KH!C1], [KH!A65536].End(3)), Range([KH!J1], [KH!H65536].End(3)), Range([KP!C1], [KP!A65536].End(3)), Range([KP!K1], [KP!I65536].End(3)))
For Each Crr In A
   Crr = Crr: N = N + 1
   For i = 3 To UBound(Crr)
      T = Format(Trim(Crr(i, 1)), "0000000"): V = Format(Val(Crr(i, 2)), "0000000"): TT = T & "/" & V
      If Z.Exists(TT) Then
         If Arr(Z(TT), 1) = "" Then
            Arr(Z(TT), 1) = Crr(1, 1)
            ElseIf InStr("/" & Arr(Z(TT), 1) & "/", "/" & Crr(1, 1) & "/") = 0 Then
            Arr(Z(TT), 1) = Arr(Z(TT), 1) & "/" & Crr(1, 1)
         End If
         Arr(Z(TT), N \ 3 + 2) = Crr(1, 3)
      End If
   Next
Next
[1!M1].Resize(UBound(Brr), 3) = Arr
End Sub

198188

回復 5# Andy2483

下載 (26.77 KB)

2024-3-4 16:20

    運行VBA后，KP内是 H- J 欄沒有讀取出來，以至黃色部分不正確。
KP & KH 兩個表格裏，都有分別有兩份資料，欄 A - C   & 欄 H - J

Andy2483

回復 6# 198188


    前輩自己測試的範例與1#的範例不同,後學猜錯需求,請上傳真正的需求範例

198188

下載 (93.37 KB)

2024-3-4 18:20

回復 7# Andy2483



規則是一樣的，不過第一範例可能看到效果沒有那麽清楚，所以上載第二範例，請以這個回復的圖片爲例

Andy2483

回復 8# 198188


    謝謝 前輩指導
原範例KP是IJK欄，請前輩試了解試改看看
Range([KP!K1], [KP!I65536].End(3))
改為
Range([KP!J1], [KP!H65536].End(3))

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖複習了一下,方案註解如下,請各位前輩指教

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, V$, Z, i&, T$, TT$, A, xA As Range, N%
'↑宣告變數:&是長整數,%是短整數,$是字串變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
Set xA = Range([1!G1], [1!A65536].End(3))
'↑令xA變數是區域儲存格(工作表 "1"裡的G1儲存格到 A欄最後有內容儲存格)
xA.Offset(1, 12).ClearContents:  Brr = xA
'↑令xA儲存格偏移下1列右12欄的區域儲存格內容清除,令Brr變數是以xA儲存格值帶入的二維陣列
For i = 2 To UBound(Brr)
'↑設順迴圈!令i從2 到Brr陣列縱向最大索引列號
   T = Format(Trim(Brr(i, 2)), "0000000"): V = Format(Val(Brr(i, 7)), "0000000"): TT = T & "/" & V
   '↑令T變數是i迴圈列2欄Brr陣列值去除頭尾空白字元後,轉化為7碼數值的字串,如果不足7碼則左側以0 補足
   '↑令V變數是i迴圈列7欄Brr陣列值轉化為數值後,再轉化為7碼數值的字串,如果不足7碼則左側以0 補足
   '↑令TT變數以"/"符號連接T與V變數所組成的新字串
   Z(TT) = i
   '↑令以TT變數為key,item是i變數(列號)納入Z字典中
Next
Arr = [1!M1].Resize(UBound(Brr), 3)
'↑令Arr變數是 工作表 "1"的M1儲存格擴展向下/向右區域儲存格值帶入的二維陣列
A = Array(Range([KH!C1], [KH!A65536].End(3)), Range([KH!J1], [KH!H65536].End(3)), Range([KP!C1], [KP!A65536].End(3)), Range([KP!K1], [KP!I65536].End(3)))
'↑令A變數是 4個區域儲存格的一維陣列
For Each Crr In A
'↑設逐項迴圈!令Crr變數是 A陣列裡的陣列值(區域儲存格)
   Crr = Crr: N = N + 1
   '↑令Crr變數轉變為 以Crr區域儲存格值帶入的二維陣列 (PS:Crr變數宣告是通用型變數,所以可以由儲存格變為二維陣列)
   For i = 3 To UBound(Crr)
   '↑設順迴圈!令i從3到Crr陣列縱向最大索引列號
      T = Format(Trim(Crr(i, 1)), "0000000"): V = Format(Val(Crr(i, 2)), "0000000"): TT = T & "/" & V
      '↑此標的為Crr陣列,T.V.TT變數意義同上
      If Z.Exists(TT) Then
      '↑如果Z字典裡有 TT變數的key?
         If Arr(Z(TT), 1) = "" Then
         '↑又如果Arr陣列裡(Z字典所記憶的列號1欄)陣列值是空字元?
            Arr(Z(TT), 1) = Crr(1, 1)
            '↑令該陣列值以 1列1欄Crr陣列值寫入
            ElseIf InStr("/" & Arr(Z(TT), 1) & "/", "/" & Crr(1, 1) & "/") = 0 Then
            '↑否則如果該陣列值沒有 1列1欄Crr陣列值
            Arr(Z(TT), 1) = Arr(Z(TT), 1) & "/" & Crr(1, 1)
            '↑令該陣列值是以 自身字串連接 1列1欄Crr陣列值所組成的新字串
         End If
         Arr(Z(TT), N \ 3 + 2) = Crr(1, 3)
         '↑令在Arr陣列裡寫入 1列3欄Crr陣列值
      End If
   Next
Next
[1!M1].Resize(UBound(Brr), 3) = Arr
'↑令工作表 "1"的M1儲存格擴展的範圍裡寫入Arr陣列值
End Sub