- 帖子
- 176
- 主題
- 98
- 精華
- 0
- 積分
- 279
- 點名
- 0
- 作業系統
- window 7
- 軟體版本
- office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2011-2-17
- 最後登錄
- 2020-4-8
|
匯出工作表出現" 陣列索引超出範圍"問題
各位高手請指教
檔案名稱 工作表名稱
file 1 101
file 1 aa.xls
file 1 102
file 2 103
file 2 104
file 2 bb.xls
跟據A欄及B欄資料將工作表匯出
而A欄名稱同樣是新檔案名稱, 匯出後A欄工作表在新檔案最左邊
B欄名稱可能是工作表或檔案名稱
如果B欄是工作表, 將工作表匯出至新檔案, 如果是檔案(.xls尾), 開啟檔案後, 將檔案內的所有工作表匯出
(若B欄的檔案不存在, 出現警告提示)
(儲存匯出檔案時, 若檔案已存在, 取代舊有檔案)
因智識所限, 寫了個類似的程式,
不知如何設定宣告及修改
但當程式去到
Sheets(Attfile).Copy before:=Workbooks(Exfile).Sheets(1)
出現"陣列索引超出範圍" ,
各位高手可以幫忙嗎
Sub export1()
'
On Error Resume Next
Dim REF As Object ' 儲存檔案名稱
Dim Exfile As String 'A欄匯出檔案名稱
Dim Path_ExFile As String 'A欄匯出檔案名稱連路徑
Dim Attfile As String 'B欄匯入工作表或檔案名
Dim Path_Attfile As String 'B欄匯入檔案名稱連路徑
Sheets("SUMMARY").Select
Range("A2").Select '由A2儲存格開始執行
Set REF = ActiveCell
Do Until IsEmpty(REF.Value) ' 執行程式直至A欄空白行才停止執行
'設定各項代數定義
Attfile = REF.Offset(0, 1) 'B欄匯入工作表或檔案名
Exfile = REF.Value 'A欄匯出檔案名稱 Packing List
Path_ExFile = "C:\" & REF 'A欄匯出檔案名稱連路徑
Path_Attfile = "C:\" & Attfile 'B欄匯入檔案名稱連路徑
If REF <> REF.Offset(-1, 0) Then 'A欄儲存格與上一行不同 (IF_0)
'當A欄儲存格與上一行不同
Sheets(Exfile).Copy 'copy 工作表並建立新檔案
ActiveWorkbook.SaveAs Filename:=Path_ExFile '跟據A欄檔案名稱儲存檔案
End If '(IF_0)
If Right(Attfile, 3) = "xls" Then '檢查B欄是否檔案(最右文字是否XLS) (IF 1)
'當B欄是檔案
Err.Clear ' 清除error code
Workbooks.Open Filename:=Path_Attfile '嘗試開啟檔案 (IF_4)
Debug.Print Err.Number '於即時運算顯示錯誤代號,只作編寫程式檢查用途
If Err.Number = 0 Then '若檔案不存在存回錯誤代號
'當檔案出已存在
Workbooks(Attfile).Sheets(1).Copy before:=Workbooks(Exfile).Sheets(1)
Workbooks(Attfile).Close
Else '(IF_4)
'當檔案不存在 , 錯誤代號不等於0時, 顯示提示訊息
MsgBox "匯出檔案 " & Exfile & " 時, 檔案 " & Path_Attfile & " 不存在", vbExclamation + vbOKOnly, "attention" '若檔案不存在時顯示檔案名稱
End If '(IF_4)
ThisWorkbook.Activate '返回export活頁簿
Else ' (IF 1)
'當B欄是工作表
ThisWorkbook.Activate '返回export活頁簿
Sheets(Attfile).Copy before:=Workbooks(Exfile).Sheets(1) 'copy 工作表去現有檔案
ThisWorkbook.Activate '返回export活頁簿
End If '(IF 1)
'檢查A欄是否已完成匯出檔案
If REF <> REF.Offset(1, 0) Then 'A欄儲存格與下一行不同 (IF_2)
Workbooks(Exfile).Save ' 儲存及關閉檔案
Workbooks(Exfile).Close
End If '(IF_2)
Set REF = REF.Offset(1, 0) ' 將A欄位置向下移一行
Loop ' 返回Do unit 繼續執行程式
End Sub |
-
-
新資料夾.rar
(45.19 KB)
|
發表於 2011-12-14 11:01
| 
