麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 可否不用打開B.xls,C.xls就可進行sheets(1)匯出匯入 [打印本頁]

作者: yangjie 時間: 2013-9-24 16:20 標題: 可否不用打開B.xls,C.xls就可進行sheets(1)匯出匯入

本帖最後由 yangjie 於 2013-9-24 16:24 編輯

請教大大:
            情況是如此:
   A.xls下巨集VBA應如何下語法? 可使
                        B.xls內 sheets(array("sheet1","sheet2","sheet3"))複製到  C.xls內(B.xls,C.xls尚未WorkBooks().OPen)
               1. 可否不用打開B.xls,C.xls就可進行匯出匯入?VBA應如何下語法?
               2.若一定得打開打開時因B.xls,C.xls本身有巨集應如何不觸發 Sub 再進行匯出匯入?VBA應如何下語法?
                                                                                          敬請協助多日來的困擾       謝謝

作者: stillfish00 時間: 2013-9-25 15:07

回復 1# yangjie
2. Application.EnableEvents = False

Sub Test()
Dim wb1 As Workbook, wb2 As Workbook
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb1 = Workbooks.Open("C:\B.xls")
Set wb2 = Workbooks.Open("C:\C.xls")
wb1.Sheets(Array("sheet1", "sheet2", "sheet3")).Copy After:=wb2.Sheets(wb2.Sheets.Count)
wb1.Close False
wb2.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

複製代碼

作者: yangjie 時間: 2013-9-26 01:41

回復 2# stillfish00
謝謝 stillfish00
               很順利萬分感激在次請教
               wb1.Sheets(Array("學生基本資料", "請假事由", "日期")).Copy After:=wb.Sheets(wb.Sheets.Count)
            若 Sheets(Array("學生基本資料", "請假事由", "日期")) 只要有一個不存在或 "請假事別"差一字等, 則會出現 error存不存在
            應如何判斷 Sheets(Array("學生基本資料", "請假事由", "日期"))存不存在,, 存不存在都沒關係?
            只要可使  wb1.Sheets(Array("學生基本資料", "請假事由", "日期")).Copy After:=wb.Sheets(wb.Sheets.Count)順利執行

作者: yangjie 時間: 2013-9-26 10:22

回復 3# yangjie
請教
               wb1.Sheets(Array("sheet1", "sheet2", "sheet3")).Copy After:=wb.Sheets(wb.Sheets.Count)
               若 wb已有Sheets("sheet1"),Sheets("sheet3"),可否先將wb.Sheets("sheet1") 更名備份在旁wb.Sheets("sheet1_old")
               再進行  wb1.Sheets(Array("sheet1", "sheet2", "sheet3")).Copy After:=wb.Sheets(wb.Sheets.Count)
         請教  應如何下語法       謝謝協助

作者: stillfish00 時間: 2013-9-26 10:25

回復 3# yangjie

Sub Test()
Dim wb1 As Workbook, wb2 As Workbook
Dim s
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb1 = Workbooks.Open("C:\B.xls")
Set wb2 = Workbooks.Open("C:\C.xls")
On Error GoTo ERR_HANDLE
For Each s In Array("sheet1", "sheet2", "sheet3")
wb1.Sheets(s).Copy After:=wb2.Sheets(wb2.Sheets.Count)
Next s
On Error GoTo 0
wb1.Close False
wb2.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ERR_HANDLE:
'忽略(陣列索引超出範圍)錯誤
If Err.Number = 9 Then Resume Next
'Other Error
Debug.Print "Error :" & Err.Number & Chr(13) & Err.Description
Stop
End Sub

複製代碼

作者: stillfish00 時間: 2013-9-26 10:56

本帖最後由 stillfish00 於 2013-9-26 10:58 編輯

回復 4# yangjie
我執行後，若 wb已有sheet1, sheet3, 會複製成 sheet1 (1)、sheet3 (1)，原本就不會覆蓋資料了，不曉得備份是甚麼用意?

作者: yangjie 時間: 2013-9-26 11:25

本帖最後由 yangjie 於 2013-9-26 11:27 編輯

謝謝 stillfish00
事因 1.  VBA寫在A.xls裡控制工作表  指定名稱sheets("sh1")
         2.  A.xls協助某學校作數位管理而操作人員比較不熟.xls
         3.  我每修改VBA或增功能.成新的A.xls  但期間在學校的A.xls又有最新資料在sheets("sh1") 裡等等，故須將學校的A.xls.sheets("sh1") 裡等等sheet copy 至新的A.xls成  .sheets("sh1") 等等而非sheets("sh1(2)") 。
      有點複雜  Sorry
         4.  因擔心操作人員比較不熟.xls 而每每搞錯故寫成傻瓜型表單處理

作者: yangjie 時間: 2013-9-26 11:35

回復 6# stillfish00

我依大大指導  作如此 step by step寫法但速度不快
應如何修訂
Sub copysheet1()
Dim wb1 As Workbook, wb2 As Workbook
Dim wb As Workbook
Dim Path1, str1, str2 As String
Path1 = Application.ActiveWorkbook.Path
Set wb = ActiveWorkbook
wb.Activate

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ChDrive Split(Path1, ":")(0)
ChDir Path1
Dim Filt As String
Dim FilterIndex As Integer
Dim FileName As Variant
Dim xlfileName As String
Dim Title As String
Filt = "Excel Files (*.xls),*.xls"
FilterIndex = 5
Title = "選擇資料匯入之來源Excel檔"
FileName = Application.GetOpenFilename _
      (FileFilter:=Filt, _
      FilterIndex:=FilterIndex, _
      Title:=Title)
If UCase(FileName) = "FALSE" Then
      MsgBox "No file was selected."
      Exit Sub
End If
xlfileName = Dir(FileName)
If IsOpen(xlfileName) Then
      Workbooks(xlfileName).Activate
      Set wb1 = Workbooks(xlfileName)
Else
      Set wb1 = Workbooks.Open(FileName, True, False)
End If
wb1.Activate

For i = 1 To wb1.Sheets.Count
      If wb1.Sheets(i).Name <> "國中" Then
         For j = 1 To wb.Sheets.Count
            If wb.Sheets(j).Name = wb1.Sheets(i).Name Then
                  wb.Sheets(j).Copy After:=wb.Sheets(wb.Sheets.Count)
                  wb.Sheets(j).Delete
                  Exit For
            End If
         Next
         wb1.Sheets(i).Copy After:=wb.Sheets(wb.Sheets.Count)
      End If
Next
wb1.Close SaveChanges:=False
' wb2.Close True
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

作者: stillfish00 時間: 2013-9-26 14:52

本帖最後由 stillfish00 於 2013-9-26 14:56 編輯

回復 8# yangjie
這樣其實是不好的更新方法，但是要你重新把VBA與資料部分分開又不太現實，8# 的code 可以把

For j = 1 To wb.Sheets.Count
If wb.Sheets(j).Name = wb1.Sheets(i).Name Then
wb.Sheets(j).Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Sheets(j).Delete
Exit For
End If
Next
wb1.Sheets(i).Copy After:=wb.Sheets(wb.Sheets.Count)

複製代碼

改成下面試看看(依4#所說更名，copy 改 move...反正wb1不儲存)

For j = 1 To wb.Sheets.Count
If wb.Sheets(j).Name = wb1.Sheets(i).Name Then
wb.Sheets(j).Name = wb.Sheets(j).Name & "_old"
Exit For
End If
Next
wb1.Sheets(i).Move After:=wb.Sheets(wb.Sheets.Count)

複製代碼

作者: yangjie 時間: 2013-9-27 21:09

回復 9# stillfish00
謝謝指導 OK 了

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