Excel表中，Sheet1中的表映射到另一个表中，重复项合并，并用VB写的，数据太多，运行太慢，求大神优化

Question

sheet1表中其他的都重复，只有一个日期不充，所以日期在另一个表中有日期1，日期2等。VB全部上传字数太多，只能贴图了。。

Sub 金属()
Range("A2:I10000").ClearContents
Range("K2:AA10000").ClearContents
For i = 2 To 500
If Sheet1.Cells(i, 1) = 0 And Sheet1.Cells(i + 1, 1) = 0 Then
Exit For
End If
For j = 2 To 500
If Cells(j, 1) = 0 And Cells(j - 1, 1) <> 0 And Cells(j, 2) = 0 And Cells(j - 1, 2) <> 0 And Cells(j, 3) = 0 And Cells(j - 1, 3) <> 0 And Cells(j, 4) = 0 And Cells(j - 1, 4) <> 0 And Cells(j, 5) = 0 And Cells(j - 1, 5) <> 0 And Cells(j, 6) = 0 And Cells(j - 1, 6) <> 0 And Cells(j, 7) = 0 And Cells(j - 1, 7) <> 0 And Cells(j, 8) = 0 And Cells(j - 1, 8) <> 0 And Cells(j, 9) = 0 And Cells(j - 1, 9) <> 0 Then
a = j
End If
b = 0
If Cells(j - 1, 1) = Sheet1.Cells(i, 1) And Cells(j - 1, 2) = Sheet1.Cells(i, 2) And Cells(j - 1, 3) = Sheet1.Cells(i, 3) And Cells(j - 1, 4) = Sheet1.Cells(i, 4) And Cells(j - 1, 5) = Sheet1.Cells(i, 5) And Cells(j - 1, 6) = Sheet1.Cells(i, 6) And Cells(j - 1, 7) = Sheet1.Cells(i, 7) And Cells(j - 1, 8) = Sheet1.Cells(i, 8) And Cells(j - 1, 9) = Sheet1.Cells(i, 9) Then
b = 1
c = Sheet1.Cells(i, 10)
d = Sheet1.Cells(i, 11)
e = j - 1
End If
Next j
If b = 0 Then
Cells(a, 1) = Sheet1.Cells(i, 1)
Cells(a, 2) = Sheet1.Cells(i, 2)
Cells(a, 3) = Sheet1.Cells(i, 3)
Cells(a, 4) = Sheet1.Cells(i, 4)
Cells(a, 5) = Sheet1.Cells(i, 5)
Cells(a, 6) = Sheet1.Cells(i, 6)
表1

表2

表1的数据映射到表二中，表1中日期、客户到款号全部相同，但入库日期不同，在表2中统计到一行中，有入库日期1，入库日期2等

Answer 1

程序显然比较乱。

不如直接发两张样表上来，把要求描述清楚，重写代码可能更方便。

Sub 金属()

Range("A2:AA10000").ClearContents

arr = Sheets("Sheet1").UsedRange
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(arr)
tmp = ""
For j = 1 To 9
tmp = tmp & arr(i, j) & "@"
Next j
d1(tmp) = d1(tmp) & arr(i, 10) & "@" & arr(i, 11) & "@"
d2(tmp) = d2(tmp) + arr(i, 10)
If Not d3.exists(tmp) Then d3(tmp) = arr(i, 12) & "@" & arr(i, 14) & "@" & arr(i, 15) & "@" & arr(i, 11)
d4(tmp) = arr(i, 11)
Next i

i = 2
For Each d In d1
tmp = d & d2(d) & "@" & d1(d)
tmp = tmp & Application.Rept("@", 12 - (Len(d1(d)) - Len(Replace(d1(d), "@", ""))))
tmp = tmp & d3(d) & "@" & d4(d)
Cells(i, 1).Resize(1, 27) = Split(tmp, "@")
i = i + 1
Next

End Sub

追问

运行时出现错误。。。

追答+181,334,0428

追问

表示不理解，+181,334,0428是什么？能说下具体怎么修改吗？谢谢了

追答QQ号码