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

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

1^# 跳轉到 »

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 滴水成河。粒米成蘿，勿輕己靈，勿以善小而不為。