返回列表 上一主題 發帖

[發問] Excel 合併對應資料

stephenlee

帖子
63 
主題
32 
精華
0 
積分
125 
點名
0  
作業系統
WIn10 
軟體版本
OFFICE2013 
閱讀權限
20 
註冊時間
2018-7-19 
最後登錄
2022-8-11 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2022-8-6 11:17 | 只看該作者

[發問] Excel 合併對應資料

自動合併資料所需

Sheet1 A欄及B欄是資料來源

而Sheet2 A欄當我需要打上job 時,B欄的Po要自動尋找被合併的內容來組合Po

B欄要用公式或者VBA 做,但一般 B2欄這些是可以用vlookup直接取得Sheet1 B欄的資料,但是如果像
Sheet2 A欄被組合了(05-06) 這樣則無法用vlookup 將他合併,如何取括號內的資料來對應取Sheet1內的Po欄資料到Sheet2 內的Po欄內,用 "/" 來分辨不同的Po。 結果像SHeet2 的一樣,如何用VBA或公式做到。謝謝

合併.rar (6.92 KB)
收藏 分享

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-1-10 
2#
發表於 2022-8-7 07:53 | 只看該作者
回復 1# stephenlee

請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, br, a1$, a2$, ky, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheets(1).Range("a1").CurrentRegion
For i = 2 To UBound(Arr): T = Arr(i, 1): xD(T) = Arr(i, 2): Next
With Sheets(2)
    Arr = .Range("a1").CurrentRegion
    For i = 2 To UBound(Arr)
        T = Arr(i, 1): If T = "" Then GoTo 99
        If xD.Exists(T) Then
            Arr(i, 2) = xD(T)
        Else
            a1 = Split(Split(T, "(")(1), "-")(0)
            a2 = Split(Split(Split(T, "(")(1), "-")(1), ")")(0)
            For Each ky In xD.keys
                br = Split(ky, "-"): If UBound(br) < 2 Then GoTo 98
                If br(2) >= a1 And br(2) <= a2 Then
                    If Arr(i, 2) = "" Then
                        Arr(i, 2) = xD(ky)
                    Else
                        Arr(i, 2) = Arr(i, 2) & "/" & xD(ky)
                    End If
                End If
98:          Next
        End If
99:     Next
    .[a1].Resize(UBound(Arr), 2) = Arr
End With
End Sub

TOP

hcm19522

帖子
1412 
主題
4 
精華
0 
積分
1422 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2025-6-18 

熱烈參與勳章
3#
發表於 2022-8-7 10:38 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/590489958
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

stephenlee

帖子
63 
主題
32 
精華
0 
積分
125 
點名
0  
作業系統
WIn10 
軟體版本
OFFICE2013 
閱讀權限
20 
註冊時間
2018-7-19 
最後登錄
2022-8-11 
4#
發表於 2022-8-8 16:43 | 只看該作者
回復  stephenlee

請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, br, a1$, a2$, ky, i&
Set xD = C ...
samwang 發表於 2022-8-7 07:53



    你好,大大

謝謝閣下花了這麼多時間幫我製作了這個VBA, 這個VBA 完全符合我的要求,非常感謝,大大很強。
在此不好意思看閣下是否能幫我再看一下,新的要求,這次的要求是要根據 job 和line 來取SHeet2 的Po。



合併 v2.rar (7.61 KB)

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-1-10 
5#
發表於 2022-8-9 09:34 | 只看該作者
你好,大大

謝謝閣下花了這麼多時間幫我製作了這個VBA, 這個VBA 完全符合我的要求,非常感謝,大 ...
stephenlee 發表於 2022-8-8 16:43


請再測試看看，謝謝
Sub test()
Dim Arr, xD, T$, i&
Set xD = CreateObject("Scripting.Dictionary")
With Sheets(2)
    Arr = .Range("a1").CurrentRegion
    For i = 2 To UBound(Arr)
        T = Arr(i, 1) & "|" & Arr(i, 2): xD(T) = Arr(i, 3)
        T = Arr(i, 1) & "|" & Split(Arr(i, 2), "-")(0): xD(T) = Arr(i, 3)
    Next
End With
With Sheets(1)
    Arr = .Range("a1").CurrentRegion
    For i = 2 To UBound(Arr)
        T = Arr(i, 1) & "|" & Arr(i, 2)
        If xD.exists(T) Then
            Arr(i, 3) = xD(T)
        Else
            T = Arr(i, 1) & "|" & Split(Arr(i, 2), "-")(0): Arr(i, 3) = xD(T)
        End If
    Next
    .Range("a1").Resize(UBound(Arr), 3) = Arr
End With
End Sub

TOP

stephenlee

帖子
63 
主題
32 
精華
0 
積分
125 
點名
0  
作業系統
WIn10 
軟體版本
OFFICE2013 
閱讀權限
20 
註冊時間
2018-7-19 
最後登錄
2022-8-11 
6#
發表於 2022-8-10 13:52 | 只看該作者
請再測試看看，謝謝
Sub test()
Dim Arr, xD, T$, i&
Set xD = CreateObject("Scripting.Dictionary ...
samwang 發表於 2022-8-9 09:34



你好,大大,謝謝你再次幫忙,好像差一點Sheet1 是資料來源,
當我在Sheet2 打上Job 和Line 後,Sheet2的Po欄會自動根據Job 和Line來取Sheet1 的Po資料, 每次資料都會變動,所以要根據Line內的范圍來取SHeet1的Po,

例如 SHeet1 的job 是
WEC-20-01     1-5        5241-MC

WEC-20-01      6-7      5242-KOL


例如我在SHeet2 打上
WEC-20-01    1-2  
WEC-20-01    3-5
WEC-20-01    6
WEC-20-01     7

由於Line在范圍內所以結果為


WEC-20-01    1-2     5241-MC
WEC-20-01    3-5      5241-MC
WEC-20-01    6           5242-KOL
WEC-20-01     7          5242-KOL

又再麻煩你看看能不能再弄一下,感激。



合併 v2.rar (7.61 KB)

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-1-10 
7#
發表於 2022-8-10 20:14 | 只看該作者
你好,大大,謝謝你再次幫忙,好像差一點Sheet1 是資料來源,
當我在Sheet2 打上Job 和Line 後,Sheet2的 ...
stephenlee 發表於 2022-8-10 13:52



4樓和6樓需求不太一樣，請再確認實際需求，謝謝

1.JPG (114.93 KB)

1.JPG

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-1-10 
8#
發表於 2022-8-11 07:49 | 只看該作者
你好,大大,謝謝你再次幫忙,好像差一點Sheet1 是資料來源,
當我在Sheet2 打上Job 和Line 後,Sheet2的 ...
stephenlee 發表於 2022-8-10 13:52


是這樣嗎? 請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, br, a1$, a2$, ky, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheets(1).Range("a1").CurrentRegion
For i = 2 To UBound(Arr)
    T = Arr(i, 1) & "|" & Arr(i, 2): xD(T) = Arr(i, 3)
Next
With Sheets(2)
    Arr = .Range("a1").CurrentRegion
    For i = 2 To UBound(Arr)
        T = Arr(i, 1) & "|" & Arr(i, 2)
        If xD.Exists(T) Then
            Arr(i, 3) = xD(T)
        Else
            a1 = Split(Arr(i, 2), "-")(0): a2 = Split(Arr(i, 2), "-")(1)
            For Each ky In xD.keys
                If Split(ky, "|")(0) <> Arr(i, 1) Then GoTo 98
                br = Split(Split(ky, "|")(1), "-")
                If UBound(br) < 1 Then GoTo 98
                If br(0) <= a1 And br(1) >= a2 Then Arr(i, 3) = xD(ky)
98:         Next
        End If
    Next
    .[a1].Resize(UBound(Arr), 3) = Arr
End With
End Sub

TOP

stephenlee

帖子
63 
主題
32 
精華
0 
積分
125 
點名
0  
作業系統
WIn10 
軟體版本
OFFICE2013 
閱讀權限
20 
註冊時間
2018-7-19 
最後登錄
2022-8-11 
9#
發表於 2022-8-11 13:23 | 只看該作者
是這樣嗎? 請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, br, a1$, a2$, ky, i&
Set xD = CreateOb ...
samwang 發表於 2022-8-11 07:49



  沒錯了,是這樣。

不好意思前面可能說得不太清楚。現在已滿足了我的工作需求了。

非常感謝大大的幫忙花了這麼長的時間幫我研究,非常感謝。
你真的很勵害。在此跪謝了。

TOP

        靜思自在 : 君子如水，隨方就圓，無處不自在。
返回列表 上一主題