[發問] 利用EXCEL巨集資料處理 EXCEL, 巨集

天嵐

如何修改以下宏, 把結果從欄位"訂貨單" 開始貼在result 上?

Sub nn()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
mystr = a.Offset(, 1) & a.Offset(, 2) & a.Offset(, 3) & a.Offset(, 4) & a.Offset(, 5)
　 If IsEmpty(d(mystr)) Then
　　　ar = a.Resize(, 6).Value
　　　d(mystr) = a.Resize(, 6).Value
　　　d1(mystr) = 1
　　　Else
　　　ar = d(mystr)
　　　ar(1, 6) = ar(1, 6) + Val(a.Offset(, 5))
　　　d1(mystr) = d1(mystr) + 1
　　End If
Next
End With
With Sheet2
　 .[A2:G65536] = ""
　 .[A2].Resize(d.Count, 6) = Application.Transpose(Application.Transpose(d.items))
　 .[G2].Resize(d.Count, 1) = Application.Transpose(d1.items)
End With
End Sub

Hsieh

你自己沒嚐試去改改看嗎?
了解整體流程語法的意義後
要修改並不困難
你應該把你修改過程中無法克服的地方拿出來討論
而非要別人直接修好給你
Sub nn()
Dim d As Object, d1 As Object, a As Range, mystr As String
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
t = Timer
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
mystr = Join(Application.Transpose(Application.Transpose(a.Offset(, 1).Resize(, 5))), "")
   If IsEmpty(d(mystr)) Then
      Ar = a.Offset(, 1).Resize(, 5).Value
      d(mystr) = a.Offset(, 1).Resize(, 5).Value
      d1(mystr) = 1
      Else
      Ar = d(mystr)
      Ar(1, 5) = Ar(1, 5) + Val(a.Offset(, 5))
      d1(mystr) = d1(mystr) + 1
    End If
Next
End With
With Sheet2
   .[A2:F65536] = ""
   .[A2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
   .[F2].Resize(d.Count, 1) = Application.Transpose(d1.items)
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

GBKEE

回復 1# 天嵐
    Sub Ex()
    Dim A, Text$, i%
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Date")
        For Each A In .Range(.[b2], .[b65536].End(xlUp))
        Text = Join(Application.Transpose(Application.Transpose(A.Resize(, 5).Value)), "-")
        If d.EXISTS(Text) Then
            d(Text) = d(Text) + 1
        Else
            d(Text) = 1
        End If
    Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Result")
        .Range("a1").CurrentRegion.Offset(1) = ""
        i = 2
        For Each A In d.keys
            .Cells(i, "A").Resize(, 5) = Split(A, "-")
            .Cells(i, "F") = d(A)
            i = i + 1
        Next
    End With
    Application.ScreenUpdating = True
End Sub

天嵐

已修改成這句, 可以達到目標, 但逐行貼上, 速度太慢, 可以簡化嗎

For i = 1 To D.Count
.Cells(1 + i, 1).Resize(1, 1) = Application.Transpose(Application.Transpose(D.items))(i, 4)
NEXT

luhpro

我覺得這個 Case 不使用 Dictionary 反而可能會更快呢, 程式如下 :

Sub Ex()
    Dim i%, j%, iSou%, iRes%, Text$
    Dim rC As Range
   
    Sheets("Result").Range("A2:G65536").Clear
   
    iRes = 2
    With Sheets("Date")
      iSou = .Range("B65536").End(xlUp).Row
      
      For j = 2 To iSou
      ' 這邊原想要套用 Join 方法但搭配 Cells 一直都說 "執行錯誤", 所以只能暫時先這樣用囉.
      Text = .Cells(j, 2) & "-" & .Cells(j, 3) & "-" & .Cells(j, 4) & "-" & .Cells(j, 5) & "-" & .Cells(j, 6)
               
        With Sheets("Result")
          Set rC = .Range(.Cells(2, 7), .Cells(iRes, 7)).Find(Text, LookIn:=xlValues)
         
          If Not rC Is Nothing Then
            i = rC.Row
            .Cells(i, 6) = .Cells(i, 6) + 1
          Else
            .Cells(iRes, 7) = Text
            .Cells(iRes, "A").Resize(, 5) = Split(Text, "-")
            .Cells(iRes, 6) = 1
            iRes = iRes + 1
          End If
        
        End With
      Next j
      
    End With
  Sheets("Result").Range("G2:G65536").Clear
End Sub

GBKEE

回復 4# 天嵐
Sub Ex()
    Dim D As Object, A As Range, Ar1(), Ar2()
    Set D = CreateObject("Scripting.Dictionary")
    With Sheets("Date")
        For Each A In .Range(.[b2], .[b65536].End(xlUp))
            Ar1 = Application.Transpose(Application.Transpose(A.Resize(, 5).Value))
            Ar2 = Application.Transpose(Application.Transpose(A.Resize(, 6).Value))
            If D.EXISTS(Join(Ar1, "")) Then
                Ar2(6) = D(Join(Ar1, ""))(6) + 1
                D(Join(Ar1, "")) = Ar2
            Else
                Ar2(6) = 1
                D(Join(Ar1, "")) = Ar2
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Result")
        .Range("a1").CurrentRegion.Offset(1) = ""
        .[A2].Resize(D.Count, 6) = Application.Transpose(Application.Transpose(D.items))
    End With
    Application.ScreenUpdating = True
End Sub

GBKEE

回復 5# luhpro
Vba 的解法有許多 端看個人喜好
Sub Ex()
    Dim Ar(), j%, Text$, R
    Sheets("Result").Range("A2:G65536").Clear
    With Sheets("Date")
        ReDim Ar(0)
        Ar(0) = Join(Application.Transpose(Application.Transpose(.[A1].Resize(1, 5))), "-")
        For j = 2 To .Range("B65536").End(xlUp).Row
        ' 套用 Join 方法搭配 Cells
            Text = Join(Application.Transpose(Application.Transpose(.Cells(j, "B").Resize(1, 5))), "-")
            R = Application.Match(Text, Ar, 0)
            With Sheets("Result")
                If Not IsNumeric(R) Then
                    ReDim Preserve Ar(UBound(Ar) + 1)
                    Ar(UBound(Ar)) = Text
                    .Cells(UBound(Ar) + 1, "A").Resize(1, 5) = Split(Text, "-")
                    .Cells(UBound(Ar) + 1, "F") = 1
                Else
                    .Cells(R, "F") = .Cells(R, "F") + 1
                End If
            End With
        Next j
    End With
End Sub

天嵐

試驗後. 都是 .Dictionary 較快, Split(Text, "-")<< 較耗時, 謝謝各大大!

Hsieh

回復 5# luhpro


    這邊原想要套用 Join 方法但搭配 Cells 一直都說 "執行錯誤", 所以只能暫時先這樣用囉.
這是因為當你指定一列的範圍做陣列時
事實上excel把此範圍看成2維陣列
而join函數的參數只能允許一維陣列

Andy2483

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

資料表:

下載 (147.76 KB)

2023-5-15 11:43

結果表:

下載 (90.54 KB)

2023-5-15 11:43

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, R1&, R&, i&, j&, TT$, T2$, T3$, T4$, T5$
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([Date!F2], [Date!A65536].End(xlUp))
'↑令Brr變數是 二維陣列,以資料表儲存格值帶入
ReDim Crr(1 To 1000, 1 To 7)
'↑宣告Crr變數是二維空陣列,縱向索引號1~1000,橫向1~7
For i = 1 To UBound(Brr)
'↑設順迴圈
   T2 = Brr(i, 2): T3 = Brr(i, 3): T4 = Brr(i, 4): T5 = Brr(i, 5)
   '↑令T2~T5變數裝入陣列值
   TT = T2 & "|" & T3 & "|" & T4 & "|" & T5
   '↑令TT變數是組合字串,用來濾重複用的key
   If Y(TT) = "" Then
   '↑如果以TT變數查Y字典得item值是""
      R = R + 1
      '↑令R變數累加1 (用來累加Crr陣列這結果陣列的列號)
      For j = 1 To 4: Crr(R, j) = Brr(i, j + 1): Next
      '↑將Brr陣列2~5欄寫入Crr陣列(1~4)欄指定的R變數列號
      Crr(R, 5) = Val(Brr(i, 6))
      '↑Crr陣列第5欄放入資料表的數量 (用Val()將字串轉為數值)
      Crr(R, 6) = 1
      '↑Crr陣列第6欄是寫入1  (第1箱)
      Crr(R, 7) = Brr(i, 1)
      '↑Crr陣列第7欄是寫入箱號 (第1箱號)
      Y(TT) = R: GoTo i01
      '↑令以TT變數為key,item是 R變數(列號),納入Y字典中
      '令程序跳到標示 i01位置繼續執行
   End If
   R1 = Y(TT)
   '↑令R1變數是 以TT變數查Y字典得item值 (用來指向Crr陣列列號)
   '是第2次以上出現的key才會跑到這裡
   Crr(R1, 5) = Crr(R1, 5) + Val(Brr(i, 6))
   '↑令數量累加
   Crr(R1, 6) = Crr(R1, 6) + 1
   '↑令箱數累加
   Crr(R1, 7) = Crr(R1, 7) & "," & Brr(i, 1)
   '↑令箱號添加在Crr陣列第7欄後面
i01: Next
With [Result!A2].Resize(R, 7)
'↑以下是關於結果表預計要寫入新結果範圍儲存格的程序
   .EntireColumn.Clear
   '↑令這些欄位做清除
   [Result!A1:G1] = [{"訂貨單","板號","料號","原產地","數量合計","箱數","箱號註記"}]
   '↑令結果表寫入標題列
   .Value = Crr
   '↑令Crr陣列值寫入這些範圍儲存格,超過此範圍的陣列值忽略
   .EntireColumn.AutoFit
   '↑令這些欄位欄寬自動調整
   Intersect(.Cells, [G:G]).NumberFormatLocal = "@"
   '↑令第7欄的格式是 文字
End With
Set Y = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub