麻辣家族討論版版 - Powered by Discuz! Board

標題: 跨欄對比 [打印本頁]

作者: 198188 時間: 2024-3-2 12:34 標題: 跨欄對比

[attach]37534[/attach]
有三個表格，在表格“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 時間: 2024-3-4 11:35

[attach]37543[/attach]回復 1# 198188

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

作者: Andy2483 時間: 2024-3-4 11:48

回復 2# 198188

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

作者: 198188 時間: 2024-3-4 12:06

回復 3# Andy2483

KH 資料表的 H1 儲存格

作者: Andy2483 時間: 2024-3-4 15:24

本帖最後由 Andy2483 於 2024-3-4 16:03 編輯

回復 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 時間: 2024-3-4 16:23

回復 5# Andy2483

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

作者: Andy2483 時間: 2024-3-4 16:40

回復 6# 198188

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

作者: 198188 時間: 2024-3-4 18:18

本帖最後由 198188 於 2024-3-4 18:20 編輯

[attach]37547[/attach]回復 7# Andy2483

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

作者: Andy2483 時間: 2024-3-4 18:25

本帖最後由 Andy2483 於 2024-3-4 19:12 編輯

回復 8# 198188

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

作者: Andy2483 時間: 2024-3-5 08:34

本帖最後由 Andy2483 於 2024-3-5 08:41 編輯

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

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

作者: 198188 時間: 2024-3-5 08:45

回復 10# Andy2483

xA.Offset(1, 12).ClearContents: Brr = xA
'↑令xA儲存格偏移下1列右12欄的區域儲存格內容清除,令Brr變數是以xA儲存格值帶入的二維陣列

這句清除内容，它是從第13欄(欄M) 到第19欄 (欄S) 的内容清除，我需要的只是第13欄欄M - 第15欄欄O, 我需要怎樣修正，才能讓他不把欄P - 欄S的資料清除？

作者: Andy2483 時間: 2024-3-5 08:52

回復 11# 198188

Intersect([1!M:O], xA.Offset(1, 12)).ClearContents
'↑令xA儲存格偏移下1列右12欄範圍與 M:O欄交集的區域儲存格內容清除

作者: 198188 時間: 2024-3-5 08:58

回復 12# Andy2483

可以了，謝謝！

Set xA = Range([1!G1], [1!A65536].End(3))
Intersect([1!M:O], xA.Offset(1, 12)).ClearContents: Brr = xA
Arr = [1!M1].Resize(UBound(Brr), 3)
[1!M1].Resize(UBound(Brr), 3) = Arr
另外如果我執行的工作表不固定名稱，怎樣修改為用activesheet?

作者: shuo1125 時間: 2024-3-5 09:04

回復 12# Andy2483
感謝Andy大熱情且專業~
也提供個xA.Offset(1, 12).Resize(, 3).ClearContents

作者: Andy2483 時間: 2024-3-5 09:09

回復 13# 198188

1.Set xA = Range([1!G1], [1!A65536].End(3)) 改為
Set xA = Range(ActiveSheet.[G1], ActiveSheet.[A65536].End(3))

2.代碼裡面有[1! 的都要改

作者: 198188 時間: 2024-3-5 09:13

回復 15# Andy2483

明白，謝謝

作者: Andy2483 時間: 2024-3-5 09:15

回復 14# shuo1125

謝謝指教,這方法沒用過,又學到一招,之前都只會用intersect

作者: 198188 時間: 2024-3-5 11:35

回復 17# Andy2483

剛剛我測試了幾次，不知道是怎麽回事，有的數據讀不出來。可否幫我看看附件，是否格式跟VBA 有衝突？

作者: Andy2483 時間: 2024-3-5 12:28

回復 18# 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(ActiveSheet.[G1], ActiveSheet.[A65536].End(3))
xA.Offset(1, 12).Resize(, 3).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 = ActiveSheet.[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!J1], [KP!H65536].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
ActiveSheet.[M1].Resize(UBound(Brr), 3) = Arr
End Sub

作者: 198188 時間: 2024-3-5 12:36

回復 19# Andy2483

不好意思，我上載錯了文件，這個才對。
部分地方無法讀取資料。

作者: Andy2483 時間: 2024-3-5 13:21

本帖最後由 Andy2483 於 2024-3-5 13:35 編輯

回復 20# 198188

序號欄原本沒有合併儲存格,基於資料的完整性,序號都一定會有,所以以A欄最後有內容儲存格來判斷其縱向範圍,
如今如果改為有合併儲存格,可以以模號欄B欄判斷縱向範圍
原本 Set xA = Range(ActiveSheet.[G1], ActiveSheet.[A65536].End(3))
改為 Set xA = Range(ActiveSheet.[G1], ActiveSheet.[B65536].End(3)(1, 0))

作者: 准提部林 時間: 2024-3-5 13:30

回復 20# 198188

模号..."固定"只在A及H欄?? 其它欄位沒有?
工作項目...只有"噴油"???

作者: 198188 時間: 2024-3-5 14:04

回復 22# 准提部林

所有位置固定欄位，只有執行的工作表名稱會有不同。

作者: 198188 時間: 2024-3-5 14:09

回復 21# Andy2483

改了，不過還是一樣。
就算不是合并的儲存格也發生不能讀取的問題。
你看看附件，我改完后，運行了，也是出現這個問題。

作者: 198188 時間: 2024-3-5 14:13

回復 22# 准提部林

另外因爲VBA裏面用中文會有亂碼，所以 ”噴油“ 兩字才安排讀取 KP & KH 儲存格的" 噴油"

作者: Andy2483 時間: 2024-3-5 14:17

回復 24# 198188

哪一筆發生不能讀取的問題??

作者: 198188 時間: 2024-3-5 14:29

[attach]37552[/attach][attach]37553[/attach][attach]37554[/attach]回復 26# Andy2483

圖片是全部結果，第2-79行已經沒有資料，第80行有，第81 -84行沒有，第85行有。

作者: Andy2483 時間: 2024-3-5 14:32

回復 Andy2483

可以了，謝謝！

Set xA = Range([1!G1], [1!A65536].End(3))
Intersect([1!M ...
198188 發表於 2024-3-5 08:58

修改為用activesheet就要在表 "1"下執行,否則會抓不到資料,
如果在工作表不更換順序的前提下可以用工作表索引號

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(Sheets(1).[G1], Sheets(1).[B65536].End(3)(1, 0))
xA.Offset(1, 12).Resize(, 3).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 = Sheets(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!J1], [KP!H65536].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
Sheets(1).[M1].Resize(UBound(Brr), 3) = Arr
End Sub

作者: 198188 時間: 2024-3-5 14:36

回復 28# Andy2483

用了這個程式，運行后，結果也跟之前一樣。第2-79行沒有資料，第80行有，第81-84行沒有資料

作者: Andy2483 時間: 2024-3-5 14:46

回復 29# 198188

資料裡可能有看不見的特殊符號

作者: 198188 時間: 2024-3-5 15:00

回復 30# Andy2483

前輩指哪個資料？ KP & KH 還是執行的工作表？
三個表裏的文字都是數字，沒有符號。

作者: Andy2483 時間: 2024-3-5 15:11

回復 31# 198188

今天才查到2列與137列關鍵字相同,後學不察,抱歉

作者: 准提部林 時間: 2024-3-5 15:15

回復 25# 198188

是問:除了噴油, 還有沒有其它? 例如:上膜??
即同一鍵值, 有不同工作內容???

BF/BH 噴油/上膜~~~

作者: 198188 時間: 2024-3-5 15:16

本帖最後由 198188 於 2024-3-5 15:20 編輯

回復 33# 准提部林

Project 名稱（BH / BF) 這些會經常變動，
KH / KP 欄裏只有噴油，沒有其他了

作者: 198188 時間: 2024-3-5 15:19

回復 32# Andy2483

執行工作表裏面的資料 (SECTION & LENGTH) 組合會有重複性的，因爲是包裝不同的NO裏，所以(SECTION & LENGTH) 組合不會是唯一

作者: Andy2483 時間: 2024-3-5 15:42

回復 35# 198188
謝謝前輩指導,請再試試看
Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, V$, Z, Q, i&, T$, TT$, A, xA As Range, N%, C%
Set Z = CreateObject("Scripting.Dictionary")
Set xA = Range(ActiveSheet.[G1], ActiveSheet.[B65536].End(3)(1, 0))
xA.Offset(1, 12).Resize(, 3).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) = Z(TT) & "/" & i
Next
Arr = ActiveSheet.[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!J1], [KP!H65536].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
      Q = Split(Z(TT) & "/", "/")
      For C = 1 To UBound(Q) - 1
         If Arr(Q(C), 1) = "" Then
            Arr(Q(C), 1) = Crr(1, 1)
            ElseIf InStr("/" & Arr(Q(C), 1) & "/", "/" & Crr(1, 1) & "/") = 0 Then
            Arr(Q(C), 1) = Arr(Q(C), 1) & "/" & Crr(1, 1)
         End If
         Arr(Q(C), N \ 3 + 2) = Crr(1, 3)
      Next
   End If
Next
Next
ActiveSheet.[M1].Resize(UBound(Brr), 3) = Arr
End Sub

作者: 198188 時間: 2024-3-5 17:55

[attach]37555[/attach]回復 36# Andy2483

測試過，答案沒有問題。
另外有個問題，請問 "噴油" 是讀取 KP & KH 工作表内 C1 & J1 的儲存格嗎？我測試過好像不是，請問程式哪個位置是操作這個的？
因爲有兩種選擇 “ 噴油” 和 “不噴油”，我想看看能不能自己修改一下。
或者能否像帖子裏的圖片，第一欄模號，第二欄長度，第三欄 “噴油” 或者空白，然後直接讀取第三欄的數據。

作者: Andy2483 時間: 2024-3-5 18:38

回復 37# 198188

Crr(1, 3) 改為 Crr(i, 3). 試試看

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)