資料庫(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後
分類 顏色
水果 紅、紅、綠、綠
蔬菜 綠、綠、紅、紅、綠 |
發表於 2012-11-9 22:52
| 
發表於 2012-11-9 23:41
| 
] = ""