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

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

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檔裡,我的每個檔只有一個活頁簿

201407-12_error.zip (929.88 KB)

努力學習

bobomi

中學生 Rank: 2

帖子: 181
主題: 5
精華: 0
積分: 197
點名: 0
作業系統: XP
軟體版本: 2000
閱讀權限: 20
性別: 女
註冊時間: 2014-3-9
最後登錄: 2024-4-29

2^#

發表於 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)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2014-12-26 11:10 | 只看該作者

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

回復 1# hasrhgni
Application.Transpose ,陣列的元素字元數大於255 個字元,會有錯誤

Option Explicit
Sub Ex()
Dim Ar(), i%, C$, A As Range, XX As Integer, Msg As Boolean
Dim S As Integer
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)
'**** 除錯程式找出欄寬限制在 255 個字元以外的儲存格 ********
Msg = False
For XX = 1 To 11
' 欄寬限制在 255 個字元以內
If Len(A(2, XX)) > 255 Then
Sheets(i).Activate
A.Select
Debug.Print Sheets(i).Name & " 工作表 [" & A.Address & "]"
Debug.Print A(2, XX)
Debug.Print "字元:" & Len(A(2, XX))
Msg = True
End If
Next
If Msg Then
Debug.Print
Application.VBE.Windows("即時運算").Visible = True
Stop
Else
Application.VBE.Windows("即時運算").Visible = False
End If
'************ 除錯結束 ****************************************
Ar(S) = A.Offset(1).Resize(, 11) '將該列A:J欄寫入陣列
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的A7以下位置
End With
End Sub