greetingsfromtw

回復 10# 准提部林

同意淮提部林前輩所言,

也請允許小弟冒昧提點看法,發言有不當處請不吝指正,小弟一定改進.

小弟以為,
提供附檔的理由之一在於解答者不需再手動自己鍵入資料去進行測試,省去麻煩.
板上前輩願意無償提供解答,提問的板友提供附檔,應不是太大困難.

理由之二在於有時不提供附檔,真的容易造成誤會,因每人想事情看事情的角度不同,
若有附檔,可能會更易理解問題所在.

其實前面回文已有不少高手前輩們回覆精妙解答,
未能答到板友想要的效果,可能就是無附檔之故導致產生對問題的誤解,
若有提供附檔,想必能免去此一遺憾.

以上所言僅供參考,不當處請海涵.

小弟斗膽,
附上小弟修改自淮提部林前輩所寫之程式碼後的版本及檔案,絕非小弟所原創,特此聲明.

vba功力太差,改得不好,希望有所幫助,有不當處也請前輩們務必指點一二,感謝.
本想寫註解,但因目前對前輩所寫的原本程式碼還不敢說已有充分的理解,
有時是知其然而不知其所以然,寧可先不寫,以免有誤導板友之嫌,請見諒...

1. '此程式碼修改自麻辣家族討論區excel高手淮提部林前輩所寫,非我自創.
   
2. '討論區網址:http://forum.twbts.com/index.php
   
3. 
   
4. Sub test()
   
5. Dim arr, brr, myD, N, T
   
6. Set myD = CreateObject("scripting.dictionary")
   
7. arr = Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8. ReDim brr(1 To UBound(arr), 1 To 4)
   
9. N = 1
   
10. For i = 1 To UBound(arr)
    
11. T = arr(i, 2) & arr(i, 3) & arr(i, 4)
    
12. If myD(T) = 1 Then GoTo 101
    
13. For j = 1 To 4
    
14. brr(N, j) = arr(i, j)
    
15. Next j
    
16. N = N + 1
    
17. myD(T) = 1
    
18. 101:
    
19. Next i
    
20. If N > 0 Then [h2].Resize(N, 4) = brr
    
21. End Sub

複製代碼

2-2 (多欄資料)多欄資料皆相同才刪除重複橫列.zip (9.44 KB)

下載次數: 17

2016-10-26 23:13

GBKEE

回復 11# greetingsfromtw
VBA 有許多寫法可達到相同的效果

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, AR(), i As Integer
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     AR = Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
   
6.     For i = 1 To UBound(AR)
   
7.       If Not D.exists(AR(i, 2) & AR(i, 3) & AR(i, 4)) Then  '** exists  傳回字典物件是否有這key值  有 True :無 False
   
8.         D(AR(i, 2) & AR(i, 3) & AR(i, 4)) = Application.Index(AR, i)  '** 工作表函數 Index
   
9.       End If
   
10.     Next
    
11.     With Range("H1")
    
12.         .CurrentRegion.Clear
    
13.         .Resize(D.Count, 4) = Application.Transpose(Application.Transpose(D.items))
    
14.     End With
    
15. End Sub
    
16. Sub Ex1()
    
17.     Dim D As Object, i As Integer
    
18.     Set D = CreateObject("scripting.dictionary")
    
19.     With Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
    
20.         For i = 1 To .Rows.Count
    
21.             If Not D.exists(.Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)) Then '** exists  傳回字典物件是否有這key值  有 True :無 False
    
22.                 D(.Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)) = .Rows(i)
    
23.             End If
    
24.         Next
    
25.     End With
    
26.     With Range("H1")
    
27.         .CurrentRegion.Clear
    
28.          .Resize(D.Count, 4) = Application.Transpose(Application.Transpose(D.items))
    
29.     End With
    
30. End Sub
    
31. Sub Ex2()
    
32.     Dim AR, ArSt(), i As Integer, St As String
    
33.     With Range("a1:d" & Cells(Rows.Count, 1).End(xlUp).Row)
    
34.         For i = 1 To .Rows.Count
    
35.                 St = .Cells(i, 2) & Cells(i, 3) & .Cells(i, 4)
    
36.                 If IsEmpty(AR) Then
    
37.                     ReDim AR(1 To 1):     AR(1) = .Rows(i)
    
38.                     ReDim ArSt(1 To 1):   ArSt(1) = St
    
39.                 Else
    
40.                     If UBound(Filter(ArSt, St)) = -1 Then
    
41.                         'Filter 函數傳回一個從零開始的陣列，該陣列包含基於指定篩選準則的一個字串陣列的子集。
    
42.                         '語法  Filter(sourcesrray, match[, include[, compare]])
    
43.                         '如果在 sourcearray 中沒有發現與 match 相符合的值，Filter 傳回一個無陣列。如果 sourcearray 是 Null 或不是一個一維陣列，則產生錯誤。
    
44.                         'Filter 函數所傳回的陣列，其組成項目數剛好是所找到的符合項目數。
    
45.                         ReDim Preserve ArSt(1 To UBound(ArSt) + 1)
    
46.                         ArSt(UBound(ArSt)) = St
    
47.                         ReDim Preserve AR(1 To UBound(AR) + 1)
    
48.                         AR(UBound(AR)) = .Rows(i)
    
49.                     End If
    
50.             End If
    
51.         Next
    
52.     End With
    
53.     With Range("H1")
    
54.         .CurrentRegion.Clear
    
55.          .Resize(UBound(AR), 4) = Application.Transpose(Application.Transpose(AR))
    
56.     End With
    
57. End Sub

複製代碼

准提部林

Application.Transpose 在不同版本的office各有其最大限制列數,
雖然大家幾乎都用了新版本, 但還是要提醒一下其他仍使用較舊版本的使用者!

greetingsfromtw

回復 12# GBKEE
回復 13# 准提部林

非常感謝GBKEE前輩提供另一種方式提供論壇板友學習,非常值得研究,小弟抱持感恩的心收下了.
也非常感謝淮提部林前輩提醒論壇板友關於Application.Transpose的限制,以後小弟練習時也會特別注意這個部份.

linsurvey2005

回復 12# GBKEE


   GBKEE前輩
附件是所需要的內容與呈現的成果
太晚回覆表示抱歉

另感謝多位前輩的指教我正在努力消化中

linsurvey2005

回復 10# 准提部林


    准提部林 前輩
問題解決了
我的疏失造成別人的困擾,下回有問題一定上傳附檔

也謝謝多位前輩的指教

Andy2483

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

執行前:

下載 (42.78 KB)

2023-5-10 11:41

執行結果:

下載 (51.08 KB)

2023-5-10 11:42

Option Explicit
Sub TEST_1()
Dim Brr, Y, i&, j&, N&, T$
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([D1], Cells(Rows.Count, "A").End(xlUp))
'↑令Brr變數是 二維陣列,以儲存格值帶入陣列裡
For i = 2 To UBound(Brr)
'↑設順迴圈
   For j = 2 To 4: T = T & Brr(i, j) & "|": Next
   '↑設內順迴圈!收集字串以"|"符號間隔
   If Y(T) = "" Then
   '↑如果以T變數查Y字典得item是 空字元?
      N = N + 1: Y(T) = "@": T = ""
      '↑令N變數累加1(指定結果資料列號),
      '令T變數當key,item是 "@",納入Y字典(這是要註記item不是 "")
      '令T變數是 空字元(因為下個迴圈執行前要清空此變數)
      For j = 1 To 4: Brr(N + 1, j) = Brr(i, j): Next
      '↑設內順迴圈!將符合條件的資料逐次帶入結果列
   End If
Next
[H:K].ClearContents
'↑令清除舊結果資料
[H1].Resize(N + 1, 4) = Brr
'↑令Brr陣列資料從[H1]儲存格開始寫入值
'(N+1:是因為第一列是標題列,而N的累計不包含標題列)
Set Y = Nothing: Erase Brr
'↑令釋放變數
End Sub