Board logo

標題: 想請教,從多個活頁簿找到關鍵字後複製下一列,但一直有錯誤 [打印本頁]
作者: hasrhgni    時間: 2014-12-26 02:54     標題: 想請教,從多個活頁簿找到關鍵字後複製下一列,但一直有錯誤

想請教,從多個活頁簿找到關鍵字後複製下一列,但一直有錯誤

Sub ex()

Dim Ar(), i%, C$, A As Range

With Sheets(1) '第一張工作表

C = "身分證或統一證號" '要篩選的值

   For i = 2 To Sheets.Count '從第2張工作表開始回圈

      With Sheets(i)

         For Each A In .UsedRange.Columns(1).Cells 'A欄已使用儲存格做迴圈

            If A = C Then '如果與要篩選的值相同

               ReDim Preserve Ar(s)

               Ar(s) = A.Offset(1).Resize(, 11) '將該列A:k欄寫入陣列

               s = s + 1

            End If

         Next

      End With

    Next

.[A4].CurrentRegion.Offset(1).ClearContents '清除舊有資料

If s > 0 Then .[A5].Resize(s, 11) = Application.Transpose(Application.Transpose(Ar)) '若有符合項目則寫入工作表1的A5以下位置

End With



End Sub


在這一行一直出現錯誤"13"型態不符合,我不知是否我的活頁簿太多,其實活頁簿共有約500頁,如果我1~60頁保留,其後都刪掉,就沒有錯誤
If s > 0 Then .[A5].Resize(s, 11) = Application.Transpose(Application.Transpose(Ar)) '若有符合項目則寫入工作表1的A5以下位置

不知可否幫忙解決,如果能有抓同一資料夾內的.xlsx檔案方法就可好了,我就不用將檔案的活頁簿塞到同一個.xlsx檔裡,我的每個檔只有一個活頁簿

[attach]19945[/attach]
作者: bobomi    時間: 2014-12-26 07:45

經測試  Application.Transpose

可能是 bug 或 有限制陣列數量

以下範例

ReDim a(1 To 11, 0 To 495)    ' ------- ok
g = Application.Transpose(a)

ReDim a(1 To 11, 0 To 496)  ' ------ err msg 型態不符
g = Application.Transpose(a)
作者: GBKEE    時間: 2014-12-26 11:10

本帖最後由 GBKEE 於 2014-12-26 15:06 編輯

回復 1# hasrhgni
Application.Transpose ,陣列的元素字元數大於255 個字元,會有錯誤
  1. Option Explicit
  2. Sub Ex()
  3. Dim Ar(), i%, C$, A As Range, XX As Integer, Msg As Boolean
  4. Dim S As Integer
  5.     With Sheets(1) '第一張工作表
  6.         C = "身分證或統一證號" '要篩選的值
  7.         For i = 2 To Sheets.Count '從第2張工作表開始回圈
  8.             With Sheets(i)
  9.                 For Each A In .UsedRange.Columns(1).Cells 'A欄已使用儲存格做迴圈
  10.                     If A = C Then '如果與要篩選的值相同
  11.                         ReDim Preserve Ar(S)
  12.                         '****  除錯程式  找出欄寬限制在 255 個字元以外的儲存格 ********
  13.                         Msg = False
  14.                         For XX = 1 To 11
  15.                             ' 欄寬限制在 255 個字元以內
  16.                             If Len(A(2, XX)) > 255 Then
  17.                                 Sheets(i).Activate
  18.                                 A.Select
  19.                                 Debug.Print Sheets(i).Name & " 工作表 [" & A.Address & "]"
  20.                                 Debug.Print A(2, XX)
  21.                                 Debug.Print "字元:" & Len(A(2, XX))
  22.                                 Msg = True
  23.                             End If
  24.                         Next
  25.                         If Msg Then
  26.                             Debug.Print
  27.                             Application.VBE.Windows("即時運算").Visible = True
  28.                             Stop
  29.                         Else
  30.                             Application.VBE.Windows("即時運算").Visible = False
  31.                         End If
  32.                         '************  除錯結束  ****************************************
  33.                         Ar(S) = A.Offset(1).Resize(, 11) '將該列A:J欄寫入陣列
  34.                         S = S + 1
  35.                     End If
  36.                 Next
  37.             End With
  38.         Next
  39.         .[A4].CurrentRegion.Offset(1).ClearContents '清除舊有資料
  40.         If S > 0 Then .[A5].Resize(S, 11) = Application.Transpose(Application.Transpose(Ar)) '若有符合項目則寫入工作表1的A7以下位置
  41.     End With
  42. End Sub
複製代碼
作者: bobomi    時間: 2014-12-26 11:29

經測試  Application.Transpose

可能是 bug 或 有限制陣列數量

以下範例

ReDim a(1 To 11, 0 To  ...
bobomi 發表於 2014-12-26 07:45


這個問題
Excel 2000  -->  會出現錯誤訊息
Excel 2014  -->  不會出現錯誤訊息
作者: hasrhgni    時間: 2014-12-26 13:34

感謝 版主GBKEE 的驗証程式,替我解決問題
感謝 bobomi 的熱心回覆,謝謝



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