vlookup合并的資料 - Excel程式區 - 麻辣家族討論版版

Andy2483

　暱稱: 厚臉皮的學生

碩士班 Rank: 5 Rank: 5

帖子: 1567
主題: 40
精華: 0
積分: 1591
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 100
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2026-2-2

1^# 跳轉到 »

發表於 2023-12-26 10:26 | 顯示全部帖子

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

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

執行結果:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

碩士班 Rank: 5 Rank: 5

帖子: 1567
主題: 40
精華: 0
積分: 1591
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 100
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2026-2-2

2^#

發表於 2023-12-29 16:16 | 顯示全部帖子

回復 16# 198188

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

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

碩士班 Rank: 5 Rank: 5

帖子: 1567
主題: 40
精華: 0
積分: 1591
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 100
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2026-2-2

3^#

發表於 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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483