返回列表 上一主題 發帖

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

ii31sakura

帖子
43 
主題
13 
精華
0 
積分
75 
點名
0  
作業系統
windows 7 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2014-5-6 
最後登錄
2019-6-17 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-5-30 14:53 | 只看該作者

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

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

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


麻煩各位大大了~感謝

test統計.rar (13.56 KB)

收藏 分享

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 2014-5-30 17:25 | 只看該作者
回復 1# ii31sakura
Excel2010
選範圍，資料>資料工具>移除重複。

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
3#
發表於 2014-5-31 10:26 | 只看該作者
回復 1# ii31sakura
試試看！
test統計.rar (17.92 KB)

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
4#
發表於 2014-5-31 10:32 | 只看該作者
回復 1# ii31sakura
執行結果：

TOP

c_c_lai

帖子
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
沒留意你仍是小學生等級，是無法下載的。
所以將程式碼貼上：
  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
複製代碼

TOP

jiwen818

帖子
4 
主題
0 
精華
0 
積分
2 
點名
0  
作業系統
win7 
軟體版本
32bits 
閱讀權限
10 
性別
男 
來自
tainan 
註冊時間
2014-4-25 
最後登錄
2014-9-30 
6#
發表於 2014-5-31 21:48 | 只看該作者
選範圍，資料>資料工具>移除重複。

TOP

ii31sakura

帖子
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

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
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

        靜思自在 : 小事不做、大事難成。
返回列表 上一主題