麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 請教各位前輩vba 關於取不重復值問題~ [打印本頁]

作者: ii31sakura 時間: 2014-5-30 14:53 標題: 請教各位前輩vba 關於取不重復值問題~

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

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

麻煩各位大大了~感謝

作者: stillfish00 時間: 2014-5-30 17:25

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

作者: c_c_lai 時間: 2014-5-31 10:26

回復 1# ii31sakura
試試看！
[attach]18420[/attach]

作者: c_c_lai 時間: 2014-5-31 10:32

回復 1# ii31sakura
執行結果：
[attach]18421[/attach]

作者: c_c_lai 時間: 2014-5-31 10:49

本帖最後由 c_c_lai 於 2014-5-31 10:52 編輯

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

Sub Ex()
Dim 第一種組合 As Object, 第二種組合 As Object, rng As Range
Set 第一種組合 = CreateObject("Scripting.Dictionary")
Set 第二種組合 = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
' .[F:L].ClearContents ' 保留複製標題
.[F12:L65535].ClearContents
For Each rng In .Range([A2], [A2].End(xlDown)) ' 每日
If IsEmpty(第一種組合(rng.Value & rng.Offset(, 1).Value & rng.Offset(, 2).Value)) Then ' 寫入字典
第一種組合(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))
Else
第一種組合(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))
End If
If IsEmpty(第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value)) Then ' 寫入字典
第二種組合(rng.Offset(, 1).Value & rng.Offset(, 2).Value) = Array(rng.Offset(, 1).Value, rng.Offset(, 2).Value, Val(rng.Offset(, 3).Value))
Else
第二種組合(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))
End If
Next
.[F12].Resize(第一種組合.Count, 4) = Application.Transpose(Application.Transpose(第一種組合.items)) ' 寫入工作表
.[J12].Resize(第二種組合.Count, 3) = Application.Transpose(Application.Transpose(第二種組合.items)) ' 寫入工作表
End With
' 釋出物件變數
Set 第一種組合 = Nothing
Set 第二種組合 = Nothing
End Sub

複製代碼

作者: jiwen818 時間: 2014-5-31 21:48

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

作者: ii31sakura 時間: 2014-6-1 13:15

回復 5# c_c_lai

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

作者: Andy2483 時間: 2023-4-17 11:52

回復 5# c_c_lai

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

執行前:
[attach]36145[/attach]

執行結果:
[attach]36146[/attach]

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)