Board logo

標題: [發問] 執行階段錯誤13 [打印本頁]
作者: jesscc    時間: 2019-10-1 20:18     標題: 執行階段錯誤13

已經近一個星期了，我簡直要被這個 "執行階段錯誤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
[attach]31302[/attach]
作者: 准提部林    時間: 2019-10-2 09:35

參考:
http://forum.twbts.com/thread-22063-1-2.html

應該是 transpose 超限問題
作者: jesscc    時間: 2019-10-2 10:04

回復 2# 准提部林

准大，您好，這個問題我也想過，但是同樣的語法，中文的資料長度更長，合併卻沒問題。
作者: 准提部林    時間: 2019-10-2 13:45

回復 3# jesscc


這文字長度如何讓transpose產生錯誤, 我也不清楚, 儘量不用~~

'英文品項合併
Dim Brr, N&, U&, TS$
Set d1 = CreateObject("Scripting.Dictionary")
ReDim Brr(1 To [T300].End(xlUp).Row, 0) '定義一個陣列[容納器]
For Each T In Range([T7], [T300].End(xlUp))
If T(1, 3) = "" Or T(1, -4) = "" Then GoTo AA 'T格或英文品項為空--略過
   TS = T(1, -4) & " " & T(1, 3) & " " & T(1, -2) '該行串接文字
   U = d1(T & "") '取得字典檔相應的[序號]
   If U > 0 Then Brr(U, 0) = Brr(U, 0) & "," & TS:   GoTo AA '如果序號大于0, 進行第2筆以後的串接
   N = N + 1:   d1(T & "") = N:   Brr(N, 0) = TS '如果序號為0, 序號遞增1存入字典檔, 填入第一個文字串
AA: Next
[AG7].Resize(N, 1) = Brr


==========================
作者: Kubi    時間: 2019-10-2 21:18

回復 3# jesscc

2010版的Excel Application.Transpose 有兩個罩門
1.置換的元素中若有超出256字元會產生錯誤。
2.置換的列數若超出65536列會產生錯誤。

執行你的程式碼後所得字元數資料如下：
嘜頭號34【中文品項合併】為21
嘜頭號34【英文品項合併】為16

嘜頭號35【中文品項合併】為161
嘜頭號35【英文品項合併】為138

嘜頭號36【中文品項合併】為211
嘜頭號36【英文品項合併】為306

嘜頭號37【中文品項合併】為176
嘜頭號37【英文品項合併】為170

嘜頭號38【中文品項合併】為8
嘜頭號38【英文品項合併】為3

資料錯誤出現在嘜頭號36【英文品項合併】為306，已超出256的上限，而所有中文品項均合乎規則，因此不會出錯。
作者: jesscc    時間: 2019-10-2 23:02

回復 5# Kubi
感謝K大，我爬了很多文，也確認了這一點。但是現在有個頭疼的地方，因為我的代碼裏還有其他幾個地方都用了Transpose這個轉置函數，將來可能會瘋狂偵錯，該如何改寫呢?准大兩個陣列並用的寫法，幼兒園程度的我不太會用?附上更新的檔案，裏面有我原始的寫法。
[attach]31306[/attach]
作者: 准提部林    時間: 2019-10-3 09:48

本帖最後由 准提部林 於 2019-10-3 09:51 編輯

回復 6# jesscc

'中文品項合併
Set d = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
   If d(T.Value) = "" Then
      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
ReDim Arr(1 To d.Count, 0), Brr(1 To d.Count, 0)
For Each k In d.keys
    N = N + 1: Arr(N, 0) = k: Brr(N, 0) = d(k)
Next
[Y7].Resize(N, 1) = Arr
[AF7].Resize(N, 1) = Brr

'=========================================
'英文品項合併
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
N = 0: ReDim Arr(1 To d1.Count, 0)
For Each k In d1.items
    N = N + 1: Arr(N, 0) = k
Next
[AG7].Resize(N, 1) = Arr


將字典檔再做一次後置處理, 納入陣列即可~~

===============================
作者: 准提部林    時間: 2019-10-3 10:03

回復 6# jesscc

兩種合併一次迴圈完成:
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
   If d(T & "") = "" Then
      d(T & "") = T(, -5) & " " & T(, -3) & " " & T(, -2)
      d1(T & "") = T(, -4) & " " & T(, 3) & " " & T(, -2)
   Else
      d(T & "") = d(T & "") & ", " & T(, -5) & " " & T(, -3) & " " & T(, -2)
      d1(T & "") = d1(T & "") & ", " & T(, -4) & " " & T(, 3) & " " & T(, -2)
    End If
Next
ReDim Arr(1 To d.Count, 0), Brr(1 To d.Count, 1 To 2)
For Each k In d.keys
    N = N + 1
    Arr(N, 0) = k
    Brr(N, 1) = d(k)
    Brr(N, 2) = d1(k)
Next
[Y7].Resize(N, 1) = Arr
[AF7].Resize(N, 2) = Brr

=======================================
作者: 准提部林    時間: 2019-10-3 10:15

回復 6# jesscc

以變數代替文字串, 避免多次引用儲存格, 可提升效率,
同時, 若須更改, 只要修改一個地方即可~~
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
    s1$ = T(, -5) & " " & T(, -3) & " " & T(, -2)
    s2$ = T(, -4) & " " & T(, 3) & " " & T(, -2)
    If d(T & "") = "" Then
       d(T & "") = s1
       d1(T & "") = s2
    Else
       d(T & "") = d(T & "") & ", " & s1
       d1(T & "") = d1(T & "") & ", " & s2
    End If
Next
ReDim Arr(1 To d.Count, 0), Brr(1 To d.Count, 1 To 2)
For Each k In d.keys
    N = N + 1
    Arr(N, 0) = k
    Brr(N, 1) = d(k)
    Brr(N, 2) = d1(k)
Next
[Y7].Resize(N, 1) = Arr
[AF7].Resize(N, 2) = Brr

=======================================
作者: jesscc    時間: 2019-10-3 11:16

感謝准大的幫忙，用您中英合併的方式確實又快又正確，不過我有個問題
    s1$ = T(, -5) & " " & T(, -3) & " " & T(, -2)
    s2$ = T(, -4) & " " & T(, 3) & " " & T(, -2)
T括號裡的數值到底是以哪一欄做基準推算出來的?
作者: ikboy    時間: 2019-10-3 13:15

試一下單字典方法
  1. Sub zz()
  2. Dim a, d As Object, c!, e!, b(9), ar, br, tr, kr, k, t, n&, kk, tt
  3. If [T7] = "" Then Exit Sub
  4. [x6].CurrentRegion.Offset(4).Clear
  5. Set d = CreateObject("scripting.dictionary")
  6. c = [ac4]
  7. e = [ac5]
  8. a = [n6].CurrentRegion
  9. ar = Array(8, 7, 6, 5)
  10. br = Array(0, 1, 3, 5)
  11. For i = 2 To UBound(a)
  12.     k = a(i, 7)
  13.     If Len(a(i, 2)) Then
  14.         kk = k & "|" & a(i, 2)
  15.         If Not d.exists(kk) Then
  16.             d(kk) = Array(a(i, 3), a(i, 4))
  17.         Else
  18.             t = d(kk)
  19.             t(0) = t(0) + a(i, 3)
  20.             d(kk) = t
  21.         End If
  22.     End If
  23.     b(8) = Join(Array(a(i, 1), a(i, 3), a(i, 4)), " ")
  24.     For j = 0 To UBound(br)
  25.         b(br(j)) = a(i, ar(j))
  26.     Next
  27.     b(2) = 1
  28.     If Not d.exists(k) Then
  29.         d(k) = b
  30.     Else
  31.         t = d(k)
  32.         n = 0
  33.         t(2) = t(2) + 1
  34.         For Each j In Array(3, 5)
  35.             t(j) = t(j) + b(j)
  36.             n = n + 1
  37.         Next
  38.         t(8) = t(8) & ", " & b(8)
  39.         d(k) = t
  40.     End If
  41. Next
  42. For i = 2 To UBound(a)
  43.     If Len(a(i, 2)) Then
  44.         k = a(i, 7)
  45.         kk = k & "|" & a(i, 2)
  46.         If d.exists(kk) Then
  47.             t = d(k)
  48.             tt = d(kk)
  49.             t(9) = t(9) & ", " & Join(Array(a(i, 2), tt(0), tt(1)))
  50.             d.Remove (kk)
  51.             d(k) = t
  52.         End If
  53.     End If
  54. Next
  55. t = d.items
  56. ReDim br(1 To d.Count, 1 To 10)
  57. ar = Array("PUMP MOTOR", "TOOLING")
  58. For i = 0 To UBound(t)
  59.     k = t(i)
  60.     For j = 0 To UBound(k)
  61.         br(i + 1, j + 1) = k(j)
  62.     Next
  63.     br(i + 1, 5) = Round(br(i + 1, 4) / e * c, 0)
  64.     n = IIf(InStr(br(i + 1, 10), "TOOLING"), 10, 2)
  65.     br(i + 1, 7) = br(i + 1, 6) + br(i + 1, 3) * n
  66.     br(i + 1, 10) = Mid(br(i + 1, 10), 3)
  67.     For jj = 0 To UBound(ar)
  68.         If InStr(br(i + 1, 10), ar(jj)) Then br(i + 1, 8) = ar(jj)
  69.     Next
  70.     If br(i + 1, 8) = "" Then br(i + 1, 8) = "MACHINE ACCESSORY"
  71. Next
  72. [x7].Resize(i, j) = br
  73. [x7].Resize(i, j).Borders.Weight = 1
  74. End Sub
複製代碼
作者: 准提部林    時間: 2019-10-3 13:34

回復 10# jesscc

那是 T.cells(?, ?) 的用法,
當格 T(1,1)
右一格 T(1,2)
左一格 T(1,0)
作者: jesscc    時間: 2019-10-3 16:28

准大，能否再幫我看一下，我改寫後工作表1的資料要轉到工作表2的代碼，因為比較少用這樣的轉資料法，所以語法不是很懂，執行起來雖然沒偵錯，但是資料也沒轉成。
[attach]31308[/attach]
作者: 准提部林    時間: 2019-10-3 17:31

回復 13# jesscc

Sub A_To_B()
Dim mRow&, Crr, Y As Range, YR, C%
Set d = CreateObject("scripting.dictionary")
mRow = Sheets("工作表2").[B500].End(xlUp).Row + 1
For Each Y In Range([Y7], [Y300].End(3))
d(Y & "") = Array(Y.Offset(, -1), Y, Y.Offset(, 6), Y.Offset(, 8), "", Y, "PKG", Y.Offset(, -1), Y.Offset(, 7), "", Y.Offset(, 3) / Y.Offset(, -1), Y.Offset(, 3), Y.Offset(, 4), Y.Offset(, 5))
If C = 0 Then C = UBound(d(Y & "")) + 1
Next

N = 0
字典檔的item是陣列, 必須逐一調用
ReDim Crr(1 To d.Count, 1 To C)
For Each k In d.keys
    N = N + 1
    YR = d(k & "")
    For j = 1 To C: Crr(N, j) = YR(j - 1): Next
Next
With Sheets("工作表2")
     .Range("B" & mRow).Resize(N, C).Value = Crr 'range前少一個 "."
     .Activate
End With
End Sub

============================
作者: jesscc    時間: 2019-10-3 20:01

回復 14# 准提部林

謝謝准大的幫忙，我再好好研究學習一下。
作者: Kubi    時間: 2019-10-3 21:25

回復 6# jesscc

只針對 test.rar 內的中的 Transpose 疑問回答如下：
若不用 Transpose 來解，可用下列迴圈方式來寫入，不過資料量多的話會花較多時間。

原式：
[AG7].Resize(d1.Count, 1) = Application.Transpose(d1.items)

改為如下：
s = d1.Items
For i = 0 To d1.Count - 1
    Cells(i + 7, 33).Value = s(i)
Next i
作者: jesscc    時間: 2019-10-3 21:38

回復 16# Kubi
謝謝K大，這樣我就不用改寫全部的程式了:'(



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