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

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

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

麻煩各位大大了~感謝

test統計.rar (13.56 KB)

樓主熱帖

Andy2483

　暱稱: 厚臉皮的學生

碩士班 Rank: 5 Rank: 5

帖子: 1517
主題: 40
精華: 0
積分: 1541
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 100
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-10-31

8^#

發表於 2023-4-17 11:52 | 只看該作者

回復 5# c_c_lai

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

執行前:

執行結果:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

ii31sakura

中學生 Rank: 2

帖子: 43
主題: 13
精華: 0
積分: 75
點名: 0
作業系統: windows 7
軟體版本: office 2007
閱讀權限: 20
註冊時間: 2014-5-6
最後登錄: 2019-6-17

7^#

發表於 2014-6-1 13:15 | 只看該作者

回復 5# c_c_lai

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

TOP

jiwen818

小學生 Rank: 1

帖子: 4
主題: 0
精華: 0
積分: 2
點名: 0
作業系統: win7
軟體版本: 32bits
閱讀權限: 10
性別: 男
來自: tainan
註冊時間: 2014-4-25
最後登錄: 2014-9-30

6^#

發表於 2014-5-31 21:48 | 只看該作者

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

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

5^#

發表於 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