標題: 歸類合併 [打印本頁]

---

作者: 198188    時間: 2012-11-9 22:52     標題: 歸類合併

資料庫(VBA前)
分類        顏色
水果        紅
水果        紅
水果        綠
水果        綠
蔬菜        綠
蔬菜        綠
蔬菜        紅
蔬菜        紅
蔬菜        綠

Sub Combine()
   Dim i As Integer, j As Integer, k As Integer
   Dim rowC As Integer
   Dim rB As Range
   Dim data() As String
   Dim found As Boolean

   '先將 O:Z 的資料清除
   Sheets(1).Range("O:Z").ClearContents

   '計算多少筆資料要處理
   rowC = Sheets(1).Range("A1").CurrentRegion.Rows.Count
   '先暫存資料，加速處理
   Set rB = Sheets(1).Range(Cells(1, 1), Cells(rowC, 14))
   ReDim data(rowC, 14)

   k = 0
   For i = 1 To rowC '處理資料
       j = 1
       found = False
       While (j <= k) And (found = False) '比對有沒有出現過
          If rB(i, 3) = data(j, 3) Then
             found = True
             data(j, 4) = data(j, 4) + "、" + rB(i, 4)
             data(j, 5) = data(j, 5) + "、" + rB(i, 5)
             data(j, 6) = data(j, 6) + "、" + rB(i, 6)
             data(j, 7) = data(j, 7) + "、" + rB(i, 7)
             data(j, 8) = data(j, 8) + "、" + rB(i, 8)
             data(j, 9) = data(j, 9) + "、" + rB(i, 9)
             data(j, 10) = data(j, 10) + "、" + rB(i, 10)
             data(j, 11) = data(j, 11) + "、" + rB(i, 11)
             data(j, 12) = data(j, 12) + "、" + rB(i, 12)
             data(j, 13) = data(j, 13) + "、" + rB(i, 13)
             data(j, 14) = data(j, 14) + "、" + rB(i, 14)
          End If
          j = j + 1
       Wend

       If found = False Then  '沒有出現過加入新資料
          k = k + 1
          data(k, 3) = rB(i, 3)
          data(k, 4) = rB(i, 4)
          data(k, 5) = rB(i, 5)
          data(k, 6) = rB(i, 6)
          data(k, 7) = rB(i, 7)
          data(k, 8) = rB(i, 8)
          data(k, 9) = rB(i, 9)
          data(k, 10) = rB(i, 10)
          data(k, 11) = rB(i, 11)
          data(k, 12) = rB(i, 12)
          data(k, 13) = rB(i, 13)
          data(k, 14) = rB(i, 14)
       End If
   Next i

   For i = 1 To k '列印資料
       Cells(i, 15) = data(i, 3)
       Cells(i, 16) = data(i, 4)
       Cells(i, 17) = data(i, 5)
       Cells(i, 18) = data(i, 6)
       Cells(i, 19) = data(i, 7)
       Cells(i, 20) = data(i, 8)
       Cells(i, 21) = data(i, 9)
       Cells(i, 22) = data(i, 10)
       Cells(i, 23) = data(i, 11)
       Cells(i, 24) = data(i, 12)
       Cells(i, 25) = data(i, 13)
       Cells(i, 26) = data(i, 14)
    Next i
   MsgBox ("Sucess")
End Sub


VBA後
分類        顏色
水果        紅、紅、綠、綠
蔬菜        綠、綠、紅、紅、綠

---

作者: Hsieh    時間: 2012-11-9 23:41

回復 1# 198188
妳的程式碼與範例說明並不一樣
若資料在A:B欄，執行後將資料放在C:D欄，試試以下代碼

1. Sub ex()
   
2. ar = Range("A1").CurrentRegion.Value
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. For i = 1 To UBound(ar, 1)
   
5. dic(ar(i, 1)) = IIf(dic(ar(i, 1)) = "", ar(i, 2), dic(ar(i, 1)) & "、" & ar(i, 2))
   
6. Next
   
7. [C:D] = ""
   
8. [C1].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
   
9. [D1].Resize(dic.Count, 1) = Application.Transpose(dic.items)
   
10. End Sub

複製代碼

---

作者: 198188    時間: 2012-11-10 01:31

ar = Range("A1").CurrentRegion.Value    這句是否計算A欄有幾多列有資料？

Set dic = CreateObject("Scripting.Dictionary")   這句不明白

For i = 1 To UBound(ar, 1)      UBound是什麼用途？

dic(ar(i, 1)) = IIf(dic(ar(i, 1)) = "", ar(i, 2), dic(ar(i, 1)) & "、" & ar(i, 2))    dic及ar是什麼意思?

Next

C] = ""
[C1].Resize(dic.Count, 1) = Application.Transpose(dic.keys)     resize及Application.Transpose是什麼意思
如何用法？可以解釋一下？

---

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