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

標題: [發問] vlookup合并的資料 [打印本頁]

作者: 198188 時間: 2023-12-20 11:42 標題: vlookup合并的資料

下圖左邊是資料檔，右邊是結果。由於貨架序號的頭7行是合幷，第8-14行是合幷，每次合幷行數不固定。
有沒有方法像右邊那樣，打入貨架序號，然後直接把該序號的資料轉到右邊？如附件。

                                                            資料檔                                                                                        結果
序号货架编号货架序号单元数量楼层备注排列方式 SR2000 SR2001
1             GS200          SR2000       FC186    1          02F          SR2001    SR2003 FC186 1 FC130 1
2                                           FC167    1          02F                         FC167 1 FC117 1
3                                           FC161    1          02F                         FC161 1 FC116 1
4                                           FC161    1          02F                         FC161 1 FC130 1
5                                           FC153    1          02F                         FC153 1 FC117 1
6                                           FC153    1          02F                         FC153 1 FC116 1
7                                           FC151    1          02F                         FC151 1 FC130 1
8                                  SR2001          FC130    1          02F                                                          Total 7 Total 7
9                                           FC117    1          02F
10                                           FC116    1          02F
11                                           FC130    1          02F
12                                           FC117    1          02F
13                                           FC116    1      02F
14                                           FC130    1          02F

作者: hcm19522 時間: 2023-12-20 12:54

(輸入編號12160) google網址:https://hcm19522.blogspot.com/

作者: 198188 時間: 2023-12-20 15:05

回復 2# hcm19522

謝謝，不過這個答應出來的效果，不是我的問題的目的。

作者: singo1232001 時間: 2023-12-21 02:37

本帖最後由 singo1232001 於 2023-12-21 02:42 編輯

回復 3# 198188

代碼需放在工作表模組不要放在Module1

Dim OUT1
Private Sub Worksheet_Change(ByVal Target As Range)
If OUT1 = True Then Exit Sub
If Target.Height > 10000 Then Exit Sub
If Target.Width > 10000 Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Target.Row > 1 Then Exit Sub
If Target.Column = 11 Then
ElseIf Target.Column = 14 Then
ElseIf Target.Column = 17 Then
ElseIf Target.Column = 20 Then
Else
Exit Sub
End If
OUT1 = True
Target.Offset(1, 0).Resize(100000, 2).ClearContents
OUT1 = False
r = Cells(Rows.Count, 1).End(3).Row
For i = 2 To r
If UCase(Target.Value) = UCase(Cells(i, 3).Value) Then
OUT1 = True
For j = i To Cells(i, 3).MergeArea.Count + i - 1
w = w + 1
Target.Offset(w, 0).Resize(1, 2).Value = Cells(j, 4).Resize(1, 2).Value
sumx = sumx + Cells(j, 5)
Next
End If
Next
If w <> 0 Then Target.Offset(w + 1, 0).Resize(1, 2) = Array("Total", sumx)
OUT1 = False
End Sub

作者: 198188 時間: 2023-12-21 09:21

本帖最後由 198188 於 2023-12-21 09:23 編輯

回復 4# singo1232001
有點奇怪，把程式放在頁面裏，但是開excel, 檢視巨集時，版面沒有任何巨集。
[attach]37166[/attach]

作者: shuo1125 時間: 2023-12-21 11:03

本帖最後由 shuo1125 於 2023-12-21 11:09 編輯

回復 5# 198188
你好~
此為工作表事件中編寫的程式碼，故不會出現在標準的「檢視巨集」列表中。
<因不屬於模組（Modules）>

作者: 198188 時間: 2023-12-21 14:12

回復 6# shuo1125

但是這樣如何操作？如上貼附件，沒有任何反應出來。

作者: shuo1125 時間: 2023-12-21 14:30

回復 7# 198188
因為你原表格是在單元格K1,N1等地方操作....所以慶大針對你需求寫的，
依原本表格填入貨號，當工作表變化時，內容就會變動了....看圖八。
-----------------------------------
[attach]37168[/attach]

作者: singo1232001 時間: 2023-12-21 18:37

回復 7# 198188

之前的代碼是在k1打字就會直接觸發操作

若想要打完再手動執行用如下代碼
Sub test()
r = Cells(Rows.Count, 1).End(3).Row
Range("k2:u1000").ClearContents
For Each Z In Range("K1,N1,Q1,T1")
t5 = 0: t4 = 0
If Z.Value <> "" Then
For i = 2 To r
If UCase(Z.Value) = UCase(Cells(i, 3).Value) Then
      For j = i To Cells(i, 3).MergeArea.Count + i - 1
      t4 = t4 & "▲" & Cells(j, 4)
      t5 = t5 & "▲" & Cells(j, 5)
      tsum = tsum + Cells(j, 5)
      Next
End If
Next

a4 = Split(Mid(t4 & "▲Total", 3, 9999), "▲")
a5 = Split(Mid(t5 & "▲" & tsum, 3, 9999), "▲")

If UBound(a4) > 0 Then
Z.Offset(1, 0).Resize(UBound(a4) + 1, 1) = Application.Transpose(a4)
Z.Offset(1, 1).Resize(UBound(a4) + 1, 1) = Application.Transpose(a5)
End If
End If
Next

End Sub

作者: 198188 時間: 2023-12-22 09:14

回復 9# singo1232001

謝謝！能不能有注釋一下，這樣我可以更好理解每句用意，如果格式或者表格有變動，也可以自己做出修改。:handshake

作者: singo1232001 時間: 2023-12-22 17:12

GPT4
在您提供的圖片中，左側是一個資料列表，右側是一個匯總結果。這個列表似乎是用於追踪庫存或貨架上的物品。貨架序號在某些行是合併的，且合併的行數不固定。您希望能夠像右邊展示的那樣，通過輸入貨架序號，直接將相關資料轉移到右側。

提供的代碼是一個 Excel 宏，用於處理這種類型的資料轉移。代碼進行了如下操作：

確定數據範圍。
清除目標範圍（K2:U1000）的內容。
遍歷特定的列（K1, N1, Q1, T1），這些列似乎是用來指定不同的貨架序號。
對於每個指定的貨架序號，代碼尋找左側列表中所有匹配的行。
將匹配行中的資料複製到右側的相應位置。
計算並添加總數到最後。
注釋您的代碼，以便於理解每一部分的功能：

vb
Copy code
Sub test()
' 獲取最後一行的行號
r = Cells(Rows.Count, 1).End(xlUp).Row
' 清除K2到U1000範圍內的所有內容
Range("k2:u1000").ClearContents

' 遍歷K1, N1, Q1, T1這四列的單元格
For Each Z In Range("K1,N1,Q1,T1")
      t5 = 0: t4 = 0 ' 初始化變量
      ' 如果當前單元格有值
      If Z.Value <> "" Then
         ' 遍歷2到最後一行
         For i = 2 To r
            ' 如果當前列的值與C列的值相同（不區分大小寫）
            If UCase(Z.Value) = UCase(Cells(i, 3).Value) Then
                  ' 遍歷合併區域的每一行
                  For j = i To Cells(i, 3).MergeArea.Count + i - 1
                     t4 = t4 & "▲" & Cells(j, 4)
                     t5 = t5 & "▲" & Cells(j, 5)
                     tsum = tsum + Cells(j, 5)
                  Next
            End If
         Next

         ' 切割字符串獲取資料數組
         a4 = Split(Mid(t4 & "▲Total", 3, 9999), "▲")
         a5 = Split(Mid(t5 & "▲" & tsum, 3, 9999), "▲")

         ' 如果數組有資料
         If UBound(a4) > 0 Then
            ' 將數據填充到指定的單元格區域
            Z.Offset(1, 0).Resize(UBound(a4) + 1, 1) = Application.Transpose(a4)
            Z.Offset(1, 1).Resize(UBound(a4) + 1, 1) = Application.Transpose(a5)
         End If
      End If
Next
End Sub
請注意，這段代碼是基於假定貨架序號列（C列）的合併區域可以通過 .MergeArea.Count 正確獲得。另外，這段代碼使用了 UCase 函數來進行不區分大小寫的比較。如果您的貨架序號區分大小寫，則不應使用 UCase 函數。

作者: Andy2483 時間: 2023-12-26 10:26

本帖最後由 Andy2483 於 2023-12-26 13:50 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,練習方案如下,請各位前輩指教
執行前:
[attach]37180[/attach]

執行結果:
[attach]37181[/attach]

Option Explicit
Sub TEST_A()
Dim 資料陣列, 空陣列(1 To 1000, 1 To 2), 字典關鍵字, 字典, 貨架序號, i&, 結果陣列
Dim 結果起始格 As Range, 結果陣列列號&
Set 字典 = CreateObject("Scripting.Dictionary")
ActiveSheet.UsedRange.Offset(, 10).EntireColumn.Delete
Set 結果起始格 = [K1]
資料陣列 = Range([E2], [D65536].End(xlUp)(2, 0))
For i = 1 To UBound(資料陣列) - 1
If 貨架序號 <> 資料陣列(i, 1) Then 貨架序號 = 資料陣列(i, 1)
If 資料陣列(i + 1, 1) = "" Then 資料陣列(i + 1, 1) = 貨架序號
貨架序號 = 資料陣列(i, 1): 結果陣列 = 字典(貨架序號): 結果陣列列號 = 字典(貨架序號 & "/r")
If Not IsArray(結果陣列) Then 結果陣列 = 空陣列
結果陣列列號 = 結果陣列列號 + 1
結果陣列(結果陣列列號, 1) = 資料陣列(i, 2): 結果陣列(結果陣列列號, 2) = 資料陣列(i, 3)
字典(貨架序號 & "/r") = 結果陣列列號: 字典(貨架序號) = 結果陣列
Next
For Each 字典關鍵字 In 字典.keys
If Not IsArray(字典(字典關鍵字)) Then GoTo V01
結果起始格 = 字典關鍵字
With 結果起始格(2, 1).Resize(字典(字典關鍵字 & "/r"), 2)
   .Value = 字典(字典關鍵字)
   .Borders.LineStyle = 1
   .Cells(.Count + 1) = "Total"
   .Cells(.Count + 2) = "=SUM(" & .Columns(2).Address & ")"
End With
Set 結果起始格 = 結果起始格(, 4)
V01: Next
End Sub

作者: 198188 時間: 2023-12-29 11:15

回復 11# singo1232001
感謝注釋，請問 ▲是什麽用途？我每次輸入變成亂碼，是否可以更改其他？

作者: singo1232001 時間: 2023-12-29 14:42

回復 13# 198188

切割區隔用而已
可能是big5 轉utf-8異常
把三角型改成兩個；；好了

作者: 198188 時間: 2023-12-29 14:51

回復 14# singo1232001

謝謝。
如果想直接抽取該儲存格内含有SR字眼，然後抽出SR及後面四個數值，例如SR2003 及 SR2002 ，這句如何用程式表達？
上架 SR2003(02F单元)
下架 SR2002(02F单元)

作者: 198188 時間: 2023-12-29 15:25

回復 12# Andy2483

其實我主要的目的是將附件，根據 BF 裏的排櫃表，製造成BF#001-009的排櫃表。
如果我想根據下面條件讀取資料。
如果儲存格内有”SR“, 一欄就抽取SR+后4個數值，另一欄就抽取（）括號内的内容
如果儲存格内沒有“SR”, 一欄就抽取第一個空格前的數值，另一欄就抽取第一個空格后的數字。

舉例
上架 SR2005(02F单元)
上架 SR2023(03F单元)
2310100528 BF GL3A-001 LAMINATED GLASS UNIT =3PCS
2311160356 AA REPLACEMENT INSULATED GLASS=1pc
2311181293 AA REPLACEMENT INSULATED GLASS=1pc

第一欄                               第二欄
SR2005                            02F单元
SR2023                            03F单元
2310100528                   BF GL3A-001 LAMINATED GLASS UNIT =3PCS
2311160356                   AA REPLACEMENT INSULATED GLASS=1pc
2311181293                   AA REPLACEMENT INSULATED GLASS=1pc

作者: 198188 時間: 2023-12-29 15:54

回復 9# singo1232001

因爲要的數據數量不固定。如果是想直接把C欄的貨架序號，全部自動讀取，不是自己輸入貨架序號呢？
舉例1
SR2000 SR2000 SR2001 SR2002 SR2003
SR2001
SR2002
SR2003

舉例2
SR2000 SR2000 SR2001 SR2002 SR2003 SR2004 SR2005
SR2001
SR2002
SR2003
SR2004
SR2005

作者: Andy2483 時間: 2023-12-29 16:16

回復 16# 198188

1.45HQ = 45'高櫃, 沒有 45HQ的櫃也標 45'高櫃這樣沒有規則

2.[E31],[E45],[E59]=4.8m 在結果表消失了,規則不明

作者: 198188 時間: 2023-12-29 16:41

本帖最後由 198188 於 2023-12-29 16:43 編輯

[attach]37203[/attach][attach]37201[/attach]

回復 198188

1.45HQ = 45'高櫃, 沒有 45HQ的櫃也標 45'高櫃這樣沒有規則

2.[E31],[E45],[E59]=4 ...
Andy2483 發表於 2023-12-29 16:16

上面的資料不需要，只是想圖一裏的資料傳入圖二裏的表格内

作者: 198188 時間: 2023-12-30 09:05

本帖最後由 198188 於 2023-12-30 09:07 編輯

[attach]37209[/attach]回復 18# Andy2483

我想了一個規則：
首先BF sheet 是讀取的資料，Demo 是一個固定的模板。
1. 根據BF 的 A 欄的數據，裏面現在有#001 - #009 ，那麽就複製9個Demo, Sheet Name 按照#001-#009 來命名。如 “ Result BF 工程#001”，“ Result BF 工程#002”，“ Result BF 工程#003”如此類推。
2. 讀取BF 裏面相應的資料到，“ Result BF 工程#001”，“ Result BF 工程#002”，“ Result BF 工程#003”等sheet
貨櫃號：BF工程#001， BF工程#002， BF工程#003， BF工程#004 。。。
貨櫃尺寸：45HC, 40HC, 20GP 根據A欄資料來讀取
出貨日期：根據A欄資料來讀取
制表日：執行VBA當天
欄C - 欄D 抽取欄B 裏面的資料
欄E -  欄F  抽取欄C 裏面的資料
欄G - 欄H 抽取欄D 裏面的資料
欄 I -  欄 J  抽取欄E 裏面的資料
欄K -  欄L  抽取欄F 裏面的資料

作者: Andy2483 時間: 2023-12-30 14:51

本帖最後由 Andy2483 於 2023-12-30 14:53 編輯

回復 20# 198188
謝謝前輩再回復新範例,以下是學習的方案,請前輩參考
Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Brr, Crr, Ar, Arr, V, Z, A, i&, R&, C%, j%, T$, K$, Qs$, Qd$, No$, Mk$, Q$
For i = Worksheets.Count To 3 Step -1: Worksheets(i).Delete: Next
Set Z = CreateObject("Scripting.Dictionary")
Brr = Union(Sheets(1).UsedRange, Sheets(1).UsedRange.Offset(1))
Crr = Range(Sheets(2).[A1], Sheets(2).UsedRange): K = [B1]
For i = 1 To UBound(Brr) - 1
If InStr(Brr(i, 1), Left(K, 4)) = 0 Then GoTo i01
A = Split(Replace(Brr(i, 1), "  ", " "), " "): Q = Left(A(0), 8): Qd = A(1)
If UBound(A) > 1 Then Qs = A(UBound(A)) Else Qs = ""
A = Z(Q): R = Z(Q & "/r"): C = 1
If Not IsArray(A) Then A = Crr: A(3, 2) = Q: A(3, 6) = Qs: A(3, 9) = Qd: A(4, 13) = Date: R = 5
R = R + 1: V = A(R, 2)
If InStr(Brr(i, 2), V) = 0 Or R = 10 Then GoTo i01
For j = 2 To UBound(Brr, 2)
   C = C + 2: T = Trim(Brr(i, j)): If T = "" Then GoTo j01
   If InStr(T, V) Then
      A(R, C) = Mid(T, 4, 6): A(R, C + 1) = Replace(Mid(T, 11), ")", "")
      Else
      Ar = Split(T, Chr(10))
      For Each Arr In Ar
         If Not Split(Arr & " ", " ")(1) Like "[A-z][A-z]" Then GoTo j01
         No = No & Chr(10) & Split(Arr, " ")(0)
         Mk = Mk & Chr(10) & Mid(Arr, InStr(Arr, Split(Arr, " ")(1)))
      Next
      A(R, C) = Mid(No, 2): A(R, C + 1) = Mid(Mk, 2): No = "": Mk = ""
   End If
j01: Next
Z(Q) = A: Z(Q & "/r") = R
i01: Brr(i + 1, 1) = IIf(Brr(i + 1, 1) = "", Brr(i, 1), Brr(i + 1, 1))
Next
If Z.Count = 0 Then Exit Sub
For Each A In Z.KEYS
If Not IsArray(Z(A)) Then GoTo A01
With Sheets(2).Copy(after:=Worksheets(Sheets.Count))
   ActiveSheet.Name = "Result " & A
   [A1].Resize(UBound(Z(A)), UBound(Z(A), 2)) = Z(A)
End With
A01: Next
Application.Goto Sheets(1).[A1]
End Sub

作者: 198188 時間: 2024-1-2 13:53

回復 21# Andy2483

我把中文變成英文，但是運行VBA沒有什麽效果出來。可以幫我看看哪裏翻譯錯了嗎？

作者: 198188 時間: 2024-1-2 17:58

回復 21# Andy2483

牽涉到亂碼，能不能將SHEET 名命名為“#”開始加後面三個數字。
例如
#001
#002
#003

作者: Andy2483 時間: 2024-1-2 18:55

回復 23# 198188

Q = Left(A(0), 8) 置換為 Q = Mid(A(0),5,4)

作者: 198188 時間: 2024-1-3 08:08

回復 24# Andy2483

改了之後在這個位置卡住了
With Sheets(2).Copy(after:=Worksheets(Sheets.Count))

作者: Andy2483 時間: 2024-1-3 08:49

回復 25# 198188

試過23#範例 Q = Mid(A(0),5,4) 執行沒問題的
再試試看或如果條件不一樣,請再上傳範例

作者: 198188 時間: 2024-1-3 08:56

回復 26# Andy2483

改了之後，在那個copy sheet 的位置卡住了計算sheet 是的位置

作者: Andy2483 時間: 2024-1-3 09:05

回復 27# 198188

下載來執行是正常的,不知道什麼原因,請路過的前輩們幫幫忙

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

[attach]37224[/attach][attach]37225[/attach]回復 28# Andy2483

我截圖了，你看看是不是T的數值亂碼的問題？

作者: Andy2483 時間: 2024-1-3 09:17

本帖最後由 Andy2483 於 2024-1-3 09:26 編輯

回復 29# 198188

https://answers.microsoft.com/zh ... 6-8cbe-c767e095fade

換台電腦試試看

作者: Andy2483 時間: 2024-1-3 09:42

回復 29# 198188

猜亂碼有關,試試看如下
[attach]37226[/attach]

修改為如下再試試
[attach]37227[/attach]

作者: 198188 時間: 2024-1-3 10:12

回復 31# Andy2483

我一改，excel 就自動關閉。:'( 試了很多次，都是這樣

作者: Andy2483 時間: 2024-1-3 10:16

回復 32# 198188

把資料與VBA搬到新開檔案試試看

作者: 198188 時間: 2024-1-3 10:31

回復 33# Andy2483

重複不斷試了幾十遍，終於可以了。謝謝。

作者: Andy2483 時間: 2024-1-3 10:38

回復 34# 198188

謝謝前輩回復
如果有測試結論或解決方法可以分享一下

作者: 198188 時間: 2024-1-3 10:52

回復 35# Andy2483

根據你說的那樣，亂碼換成英文，這樣就可以了
另外還有一個小的問題
能不能獨立做一個VBA 把全部sheets 裏面的文字按照附件Translate這個表裏的資料進行取代，
舉例
排櫃表 Container Maps
貨櫃號 Project Name
貨物 Description
貨櫃尺寸 Container Size
出貨日期 Ex-Work Date
櫃號 Container No
制表人 Prepared By
制表日 Date
上架 Upper Crate
下架 Lower Crate
車頭 Container Head
架長 Shelf Length

如果sheet 裏面有“排櫃表”的字眼，那麽執行程式后，“Container Maps” 取代“排櫃表”

作者: Andy2483 時間: 2024-1-3 10:58

回復 36# 198188

錄製巨集就可以做,請先試試看
再以副程式的方式排入主程式裡執行

作者: Andy2483 時間: 2024-1-3 13:58

回復 36# 198188

Option Explicit
Sub Map()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Brr, Crr, Ar, Arr, V, Z, A, i&, R&, C%, j%, T$, K$, Qs$, Qd$, No$, Mk$, Q$, S%
For i = Worksheets.Count To 4 Step -1: Worksheets(i).Delete: Next
Set Z = CreateObject("Scripting.Dictionary")
Brr = Sheets(3).UsedRange
For i = 1 To UBound(Brr): Z(Trim(Brr(i, 1))) = Trim(Brr(i, 2)): Next: S = Z.Count
Brr = Union(Sheets(1).UsedRange, Sheets(1).UsedRange.Offset(1))
Crr = Range(Sheets(2).[A1], Sheets(2).UsedRange): K = [B1]
For i = 1 To UBound(Brr) - 1
If InStr(Brr(i, 1), Left(K, 4)) = 0 Then GoTo i01
A = Split(Replace(Brr(i, 1), "  ", " "), " "): Q = Mid(A(0), 5, 4): Qd = A(1)
If UBound(A) > 1 Then Qs = A(UBound(A)) Else Qs = ""
A = Z(Q): R = Z(Q & "/r"): C = 1
If Not IsArray(A) Then A = Crr: A(3, 2) = Q: A(3, 6) = Qs: A(3, 9) = Qd: A(4, 13) = Date: R = 5
R = R + 1: V = A(R, 2)
If InStr(Brr(i, 2), V) = 0 Or R = 10 Then GoTo i01
For j = 2 To UBound(Brr, 2)
   C = C + 2: T = Trim(Brr(i, j)): If T = "" Then GoTo j01
   If InStr(T, V) Then
      A(R, C) = Mid(T, 4, 6): A(R, C + 1) = Replace(Mid(T, 11), ")", "")
      Else
      Ar = Split(T, Chr(10))
      For Each Arr In Ar
         If Not Split(Arr & " ", " ")(1) Like "[A-z][A-z]" Then GoTo j01
         No = No & Chr(10) & Split(Arr, " ")(0): Mk = Mk & Chr(10) & Mid(Arr, InStr(Arr, Split(Arr, " ")(1)))
      Next
      A(R, C) = Mid(No, 2): A(R, C + 1) = Mid(Mk, 2): No = "": Mk = ""
   End If
j01: Next
Z(Q) = A: Z(Q & "/r") = R
i01: Brr(i + 1, 1) = IIf(Brr(i + 1, 1) = "", Brr(i, 1), Brr(i + 1, 1))
Next
If Z.Count = 0 Then Exit Sub
For Each A In Z.KEYS
If Not IsArray(Z(A)) Then GoTo A01 Else Sheets(2).Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = A '"Result " & A
[A1].Resize(UBound(Z(A)), UBound(Z(A), 2)) = Z(A)
For i = 0 To S - 1: ActiveSheet.UsedRange.Replace Z.KEYS()(i), Z.ITEMS()(i), Lookat:=xlPart: Next
A01: Next
Application.Goto Sheets(1).[A1]
End Sub

作者: 198188 時間: 2024-1-3 14:33

回復 38# Andy2483

我自己加了翻譯的程式，但是我在excel加插一個SHEET 后，執行你的那個VBA，會刪除我加插的那個SHEET. 請問是哪裏的問題？

作者: Andy2483 時間: 2024-1-3 14:55

回復 39# 198188

For i = Worksheets.Count To 3 Step -1
換成
For i = Worksheets.Count To 4 Step -1

PS:
試試#38

作者: 198188 時間: 2024-1-3 16:04

回復 40# Andy2483

可以了，謝謝。之前我改過，但是改完后按執行VBA時沒反應，後來重複幾遍，改完存儲再關閉EXCEL, 再重新打開，才能成功。

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