Sub 合併()
Range(Cells(2, 8), Cells([F65536].End(xlUp).Row, 8)).ClearContents
For i = 2 To [A65536].End(xlUp).Row
y = 0
For x = 1 To [F65536].End(xlUp).Row
If Cells(i, 2) = Cells(x, 6) Then
y = y + 1
End If
Next
x = [F65536].End(xlUp).Row + 1
If y = 0 Then
n = Cells(i, 1)
Cells(x, 6) = Cells(i, 2)
End If
Next
For x = 2 To [F65536].End(xlUp).Row
n = ""
For i = 2 To [A65536].End(xlUp).Row
If Cells(i, 2) = Cells(x, 6) Then
n = n & Cells(i, 1) & "(" & Cells(i, 3) & ")" & " "
If Cells(x, 8) = "" Then
Cells(x, 8) = Cells(i, 4)
End If
End If
Next
Cells(x, 7) = n
Next
End Sub
可以請教板大高手 以下巨集可否有改進空間 搜尋B欄資料後，並且合併相同資料。 資料若數萬筆要跑20~30分鐘。?
2016-06-23 1:07 pm
回答 (3)
2016-06-28 7:16 am
將程式改成如下,試看看:
Sub 合併1()
On Error Resume Next
xR = Cells(Rows.Count, 1).End(3).Row
Arr = [A2:C2].Resize(xR - 1)
ReDim Brr(1 To xR, 1 To 2)
For J = 2 To xR
yR = Cells(Rows.Count, "F").End(3).Row
If Columns(6).Find(Cells(J, 2)).Row = 0 Then
Cells(yR + 1, "F") = Cells(J, 2)
End If
Next
Set xD = CreateObject("SCRIPTING.DICTIONARY")
For K = 1 To xR - 1
T = Arr(K, 2)
If xD(T) = 0 Then
U = U + 1
xD(T) = U
Brr(U, 1) = Arr(K, 2)
End If
Brr(xD(T), 2) = Brr(xD(T), 2) & Arr(K, 1) & "(" & Arr(K, 3) & ")" & " "
Next
zR = Cells(Rows.Count, "F").End(3).Row
Crr = Range("F2:F" & xR)
Range("G2:G" & zR) = Application.WorksheetFunction.VLookup(Crr, Brr, 2, 0)
End Sub
Sub 合併1()
On Error Resume Next
xR = Cells(Rows.Count, 1).End(3).Row
Arr = [A2:C2].Resize(xR - 1)
ReDim Brr(1 To xR, 1 To 2)
For J = 2 To xR
yR = Cells(Rows.Count, "F").End(3).Row
If Columns(6).Find(Cells(J, 2)).Row = 0 Then
Cells(yR + 1, "F") = Cells(J, 2)
End If
Next
Set xD = CreateObject("SCRIPTING.DICTIONARY")
For K = 1 To xR - 1
T = Arr(K, 2)
If xD(T) = 0 Then
U = U + 1
xD(T) = U
Brr(U, 1) = Arr(K, 2)
End If
Brr(xD(T), 2) = Brr(xD(T), 2) & Arr(K, 1) & "(" & Arr(K, 3) & ")" & " "
Next
zR = Cells(Rows.Count, "F").End(3).Row
Crr = Range("F2:F" & xR)
Range("G2:G" & zR) = Application.WorksheetFunction.VLookup(Crr, Brr, 2, 0)
End Sub
2016-06-26 4:33 am
可否說明一下需求
第一段的n要做什麼
y要做什麼
第一段的n要做什麼
y要做什麼
2016-06-23 1:40 pm
bonjour
收錄日期: 2021-04-28 16:52:23
原文連結 [永久失效]:
https://hk.answers.yahoo.com/question/index?qid=20160623050716AAq3cY1