請教一個VBA排序問題

tonycho33

請問一下我目前有三個資料 WW,XX,YY各有帶出的資料A1,A2,A3,A4,A5
如果想以A1,A2,A3,A4,A5為分類排序WW,XX,YY,且需按照順序1,2,3下來
要如何寫VBA呢

Hsieh

回復 1# tonycho33

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5:H5,C7:H7,C9:H9").SpecialCells(xlCellTypeConstants)
   
4.    If IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2)
   
5. Next
   
6. For Each a In [K5:K9]
   
7. ar = Split(d(a.Value), ",")
   
8.    a.Offset(, 1).Resize(, UBound(ar) + 1) = ar
   
9. Next
   
10. End Sub

複製代碼

tonycho33

回復 2# Hsieh


    請問可以解釋一下嗎？
如果我的原始資料欄位有新增或是列數變不同（空格2列改為3列） 要如何修改呢

Hsieh

回復 3# tonycho33

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5", [A65536].End(xlUp).Offset(, 7)).SpecialCells(xlCellTypeConstants) '再B:H欄的的非空格做迴圈
   
4.    If IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2) '如果未出現過就以該儲存格內容加入否則就將原有字串以逗點連結該儲存格內容
   
5. Next
   
6. For Each a In Range("k5", [K65536].End(xlUp)) '在K欄所有資料做迴圈
   
7. ar = Split(d(a.Value), ",")  '將以K欄儲存格為關鍵字的字典內容以逗點做分割得到一個陣列
   
8. a.Offset(, 1).Resize(, UBound(ar) + 1) = ar '將陣列寫入L欄向右
   
9. Next
   
10. End Sub

複製代碼

tonycho33

回復 4# Hsieh


    請問如果原始資料是公式算出的，會無法使用這套程式
是否可解決呢
謝謝

Hsieh

回復 5# tonycho33

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5", [A65536].End(xlUp).Offset(, 7)).SpecialCells(xlCellTypeFormulas) '再B:H欄的的公式儲存格做迴圈
   
4.    If a.Value<>"" And IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2) '如果未出現過就以該儲存格內容加入否則就將原有字串以逗點連結該儲存格內容
   
5. Next
   
6. For Each a In Range("k5", [K65536].End(xlUp)) '在K欄所有資料做迴圈
   
7. ar = Split(d(a.Value), ",")  '將以K欄儲存格為關鍵字的字典內容以逗點做分割得到一個陣列
   
8. a.Offset(, 1).Resize(, UBound(ar) + 1) = ar '將陣列寫入L欄向右
   
9. Next
   
10. End Sub

複製代碼

tonycho33

請問之前使用您的公式後
我套用之後會出現一些重複或是空格（附件）
要如何解決呢

Hsieh

回復 7# tonycho33

1. Sub nn2()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5", [O65536].End(xlUp)).SpecialCells(xlCellTypeConstants) '在C:O欄的的非空格做迴圈
   
4. If a <> 0 Then
   
5.    If IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2) '如果未出現過就以該儲存格內容加入否則就將原有字串以逗點連結該儲存格內容
   
6. End If
   
7. Next
   
8. For Each a In Range("q5", [q65536].End(xlUp)) '在K欄所有資料做迴圈
   
9. ar = Split(d(a.Value), ",")  '將以K欄儲存格為關鍵字的字典內容以逗點做分割得到一個陣列
   
10. a.Offset(, 1).Resize(, UBound(ar) + 1) = ar '將陣列寫入L欄向右
    
11. Next
    
12. End Sub

複製代碼

Andy2483

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

執行前:

下載 (109 KB)

2023-4-12 15:19

執行結果:

下載 (124.59 KB)

2023-4-12 15:20

Option Explicit
Sub TEST()
Dim Brr, Y, i&, j&, N&, T$, T1$, Ma%
Dim xR As Range, Ra As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = ActiveSheet: [Q:IA].ClearContents
Set xR = Range(Sh.[IA5], Sh.Cells(Rows.Count, "B").End(3))
Brr = xR
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): If T1 = "" Then GoTo i01
   For j = 2 To 14
      T = Brr(i, j): If T = "" Then GoTo i02
      If InStr(T, "A") Then
         T = Format(Mid(T, 2), "A" & "000")
         If Y(T) = "" Then
            N = N + 1: Brr(N, 16) = T
            Y(T) = N: Y(T & "/c") = 17
            Else
               Y(T & "/c") = Y(T & "/c") + 1
               If Ma < Y(T & "/c") Then Ma = Y(T & "/c")
         End If
         Brr(Y(T), Y(T & "/c")) = T1
      End If
i02:
   Next
i01:
Next
With [B5].Resize(UBound(Brr), Ma + 16)
   .Value = Brr
   With Intersect(.Cells, .Cells.Offset(0, 15))
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2
      For i = 1 To N: .Item(i, 1) = "A" & Val(Mid(.Item(i, 1), 2)): Next
   End With
End With
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase Brr
End Sub