Andy2483

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

下載 (138.96 KB)

2023-12-26 10:25

執行結果:

下載 (172.08 KB)

2023-12-26 10:25

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

singo1232001

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 函數。

198188

回復 9# singo1232001


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

singo1232001

回復 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

shuo1125

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

下載 (177.34 KB)

2023-12-21 14:30

198188

回復 6# shuo1125


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

shuo1125

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

198188

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

下載 (95.4 KB)

2023-12-21 09:21

singo1232001

回復 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

回復 2# hcm19522


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