標題: 匯出工作表出現" 陣列索引超出範圍"問題 [打印本頁]

---

作者: enoch    時間: 2011-12-14 11:01     標題: 匯出工作表出現" 陣列索引超出範圍"問題

各位高手請指教

檔案名稱        工作表名稱
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

---

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