返回列表 上一主題 發帖

[發問] 執行階段錯誤13

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

應該是 transpose 超限問題
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 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


==========================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

本帖最後由 准提部林 於 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



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

===============================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 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


=======================================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 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

=======================================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 10# jesscc

那是 T.cells(?, ?) 的用法,
當格 T(1,1)
右一格 T(1,2)
左一格 T(1,0)
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 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

============================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

        靜思自在 : 要用心,不要操心、煩心。
返回列表 上一主題