Board logo

標題: 請教一個VBA排序問題 [打印本頁]
作者: tonycho33    時間: 2011-11-30 18:22     標題: 請教一個VBA排序問題

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

回復 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    時間: 2011-12-1 10:50

回復 2# Hsieh


    請問可以解釋一下嗎？
如果我的原始資料欄位有新增或是列數變不同（空格2列改為3列） 要如何修改呢
作者: Hsieh    時間: 2011-12-1 15:14

回復 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    時間: 2011-12-1 17:45

回復 4# Hsieh


    請問如果原始資料是公式算出的，會無法使用這套程式
是否可解決呢
謝謝
作者: Hsieh    時間: 2011-12-1 20:49

回復 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    時間: 2011-12-9 11:52

請問之前使用您的公式後
我套用之後會出現一些重複或是空格（附件）
要如何解決呢
作者: Hsieh    時間: 2011-12-9 17:25

回復 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    時間: 2023-4-12 15:22

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

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

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


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



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