麻辣家族討論版版's Archiver

天嵐 發表於 2010-5-7 01:05

利用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 發表於 2010-5-7 08:31

[i=s] 本帖最後由 Hsieh 於 2010-5-9 21:50 編輯 [/i]

你自己沒嚐試去改改看嗎?
了解整體流程語法的意義後
要修改並不困難
你應該把你修改過程中無法克服的地方拿出來討論
而非要別人直接修好給你
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 發表於 2010-5-7 19:45

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=250&ptid=110]1#[/url] [i]天嵐[/i] [/b]
    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

天嵐 發表於 2010-5-9 12:50

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

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

luhpro 發表於 2010-5-9 16:17

我覺得這個 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 發表於 2010-5-9 19:07

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=473&ptid=110]4#[/url] [i]天嵐[/i] [/b]
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 發表於 2010-5-9 19:49

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=480&ptid=110]5#[/url] [i]luhpro[/i] [/b]
[b]Vba 的解法有許多 端看個人喜好[/b]
[b]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 [/b]
[b]            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[/b]

天嵐 發表於 2010-5-9 23:17

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

Hsieh 發表於 2010-5-13 08:37

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=480&ptid=110]5#[/url] [i]luhpro[/i] [/b]


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

Andy2483 發表於 2023-5-15 11:45

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

資料表:
[attach]36356[/attach]

結果表:
[attach]36357[/attach]


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

頁: [1]

麻辣家族討論版版為 麻辣學園 網站成員  由 昱得資訊工作室 © Since 1993 所提供