已經近一個星期了，我簡直要被這個 "執行階段錯誤13"搞得快瘋了，一直不斷地修改程式碼，但是錯誤一直不客氣地出現，請各位救救我吧!
以下是程式碼，紅字是出現偵錯的部分，附檔裡另有詳細說明
Sub C_MERGE()
If [T7] = "" Then Exit Sub
[X7:AG100].ClearContents
Dim cRow&, T As Range
Set d = CreateObject("Scripting.Dictionary") '中文品項合併
For Each T In Range([T7], [T300].End(xlUp))
If d(T.Value) = "" Then '如果T欄資料只有一筆不重複
d(T.Value) = T.Offset(, -6) & " " & T.Offset(, -4) & " " & T.Offset(, -3)
Else
d(T.Value) = d(T.Value) & ", " & T.Offset(, -6) & " " & T.Offset(, -4) & " " & T.Offset(, -3)
End If
Next
[Y7].Resize(d.Count, 1) = Application.Transpose(d.keys)
[AF7].Resize(d.Count, 1) = Application.Transpose(d.items)
Set d = Nothing
'--------------------------
Set d1 = CreateObject("Scripting.Dictionary") '英文品項合併
For Each T In Range([T7], [T300].End(xlUp))
If T.Offset(, 2) = "" Then GoTo AA
If d1(T.Value) = "" Then
d1(T.Value) = T.Offset(, -5) & " " & T.Offset(, 2) & " " & T.Offset(, -3)
Else
d1(T.Value) = d1(T.Value) & ", " & T.Offset(, -5) & " " & T.Offset(, 2) & " " & T.Offset(, -3)
End If
AA: Next
[AG7].Resize(d1.Count, 1) = Application.Transpose(d1.items)
Set d1 = Nothing
cRow = Range("Y100").End(xlUp).Row
If cRow < 7 Then Exit Sub
Range("X7:X" & cRow).Formula = "=VLOOKUP(Y7,T:U,2,FALSE)"
Range("Z7:Z" & cRow).Formula = "=COUNTIF(T$7:T$490,Y7)"
Range("AA7:AA" & cRow).Formula = "=SUMIF(T$7:T$490,Y7,S$7:S$490)"
Range("AB7:AB" & cRow).Formula = "=ROUND(AA7/$AC$5*$AC$4,0)"
Range("AC7:AC" & cRow).Formula = "=SUMIF(T$7:T$390,Y7,R$7:R$390)"
Range("AD7:AD" & cRow).Formula = "=IF(AE7=""TOOLING"",AC7+Z7*10,AC7+Z7*2)"
End Sub
 test.rar (24.77 KB)
|
發表於 2019-10-1 20:18
| 
