[發問] 請教各位前輩vba 關於取不重復值問題~

ii31sakura

不好意思、請問各位前輩、小弟目前的資料情況如下：

1. "A~C"欄位為總資料來源
2. "F~H"與"J~K"欄位為小弟想要整理出來的資料、小弟想要將總資料來源整理成像"F~H"與"J~K"的結果(不含重復性資料清單)，
     主要目前卡在這一邊(小弟也爬文找了其它例子、目前只找到單一欄位整理出不含重復性方法..但像此種多欄位不知如何著手..)，
     故於此請教大大們小弟該如何著手、之後小弟將依"倉庫別清單"分別去開新sheet與將"品名"依清單填入。


麻煩各位大大了~感謝

stillfish00

回復 1# ii31sakura
Excel2010
選範圍，資料>資料工具>移除重複。

c_c_lai

回復 1# ii31sakura
試試看！
test統計.rar (17.92 KB)

下載次數: 4

2014-5-31 10:25

c_c_lai

回復 1# ii31sakura
執行結果：

下載 (27.71 KB)

2014-5-31 10:31

c_c_lai

回復 1# ii31sakura
沒留意你仍是小學生等級，是無法下載的。
所以將程式碼貼上：

1. Sub Ex()
   
2.     Dim 第一種組合 As Object, 第二種組合 As Object, rng As Range
   
3.    
   
4.     Set 第一種組合 = CreateObject("Scripting.Dictionary")
   
5.     Set 第二種組合 = CreateObject("Scripting.Dictionary")
   
6.    
   
7.     With Sheets("DATA")
   
8.         '  .[F:L].ClearContents                         '  保留複製標題
   
9.         .[F12:L65535].ClearContents
   
10.         For Each rng In .Range([A2], [A2].End(xlDown))   '  每日
    
11.             If IsEmpty(第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value)) Then               '  寫入字典
    
12.                 第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Value, rng.Offset(, 1).Value, rng.Offset(, 2).Value, Val(rng.Offset(, 3).Value))
    
13.             Else
    
14.                 第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Value, rng.Offset(, 1).Value, rng.Offset(, 2).Value, 第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value)(3) + Val(rng.Offset(, 3).Value))
    
15.             End If
    
16.             
    
17.             If IsEmpty(第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value)) Then               '  寫入字典
    
18.                 第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Offset(, 1).Value, rng.Offset(, 2).Value, Val(rng.Offset(, 3).Value))
    
19.             Else
    
20.                 第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Offset(, 1).Value, rng.Offset(, 2).Value, 第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value)(2) + Val(rng.Offset(, 3).Value))
    
21.             End If
    
22.         Next
    
23.         
    
24.         .[F12].Resize(第一種組合.Count, 4) = Application.Transpose(Application.Transpose(第一種組合.items))   '  寫入工作表
    
25.         .[J12].Resize(第二種組合.Count, 3) = Application.Transpose(Application.Transpose(第二種組合.items))   '  寫入工作表
    
26.     End With
    
27.     '  釋出物件變數
    
28.     Set 第一種組合 = Nothing
    
29.     Set 第二種組合 = Nothing
    
30. End Sub

複製代碼

jiwen818

選範圍，資料>資料工具>移除重複。

ii31sakura

回復 5# c_c_lai

感謝c_c_lai 大大與 stillfish00大大的教導，stillfish00大大的方式在第一次整理資料時蠻有用的，
只是小弟的資料是天天需更新的、所以會比較麻煩一點、也謝謝c_c_lai 大大的熱心幫忙，
大大所提供的程式碼對小弟來說幫助蠻大的，所以在此謝謝大家囉 !.!

Andy2483

回復 5# c_c_lai


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

執行前:

下載 (112.51 KB)

2023-4-17 11:50

執行結果:

下載 (145.6 KB)

2023-4-17 11:50

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 7), Y, R1&, R2&, N&, i&, j&, T(4)
Dim xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([D1], [A1].End(xlDown)): Brr = xR
For i = 2 To UBound(Brr)
   For j = 1 To 4: T(j) = Brr(i, j): Next
   If i = 2 Then
      R1 = 1: R2 = 1
      For j = 1 To 4: Crr(1, j) = Brr(1, j): Next
      For j = 5 To 7: Crr(1, j) = Brr(1, j - 3): Next
   End If
   T(0) = "倉品|" & T(2) & "|" & T(3)
   If Y(T(0)) = "" Then
      R2 = R2 + 1
      Y(T(0)) = R2
      For j = 5 To 7: Crr(R2, j) = T(j - 3): Next
      Else
         N = Y(T(0)): Crr(N, 7) = Crr(N, 7) + T(4)
   End If
   T(0) = "日|" & T(1) & "|" & T(0)
   If Y(T(0)) = "" Then
      R1 = R1 + 1: Y(T(0)) = R1
      For j = 1 To 4: Crr(R1, j) = T(j): Next
      Else
         N = Y(T(0)): Crr(N, 4) = Crr(N, 4) + T(4)
   End If
Next
With Rows(UBound(Brr) + 2 & ":65536")
   .Clear
   With .Item(1).Resize(R1 + 1, 7)
      .Value = Crr
      With Intersect(.Cells, [A:D])
         .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, _
         Key3:=.Item(3), Order2:=1, Header:=1
      End With
      With Intersect(.Cells, [E:G])
         .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
      End With
   End With
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub