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

yangjie

請教大大:
                情況是如此:
      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

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

1. Sub Test()
   
2.   Dim wb1 As Workbook, wb2 As Workbook
   
3.   
   
4.   Application.EnableEvents = False
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   
   
8.   Set wb1 = Workbooks.Open("C:\B.xls")
   
9.   Set wb2 = Workbooks.Open("C:\C.xls")
   
10.   wb1.Sheets(Array("sheet1", "sheet2", "sheet3")).Copy After:=wb2.Sheets(wb2.Sheets.Count)
    
11.   wb1.Close False
    
12.   wb2.Close True
    
13.   
    
14.   Application.DisplayAlerts = True
    
15.   Application.ScreenUpdating = True
    
16.   Application.EnableEvents = True
    
17. End Sub

複製代碼

yangjie

回復 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

回復 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

回復 3# yangjie

1. Sub Test()
   
2.   Dim wb1 As Workbook, wb2 As Workbook
   
3.   Dim s
   
4.   
   
5.   Application.EnableEvents = False
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   
   
9.   Set wb1 = Workbooks.Open("C:\B.xls")
   
10.   Set wb2 = Workbooks.Open("C:\C.xls")
    
11.   
    
12.   On Error GoTo ERR_HANDLE
    
13.     For Each s In Array("sheet1", "sheet2", "sheet3")
    
14.       wb1.Sheets(s).Copy After:=wb2.Sheets(wb2.Sheets.Count)
    
15.     Next s
    
16.   On Error GoTo 0
    
17.   
    
18.   wb1.Close False
    
19.   wb2.Close True
    
20.   
    
21.   Application.DisplayAlerts = True
    
22.   Application.ScreenUpdating = True
    
23.   Application.EnableEvents = True
    
24.   Exit Sub
    
25.    
    
26. ERR_HANDLE:
    
27.   '忽略(陣列索引超出範圍)錯誤
    
28.   If Err.Number = 9 Then Resume Next
    
29.   
    
30.   'Other Error
    
31.   Debug.Print "Error :" & Err.Number & Chr(13) & Err.Description
    
32.   Stop
    
33. End Sub

複製代碼

stillfish00

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

yangjie

謝謝    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

回復 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

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

1.             For j = 1 To wb.Sheets.Count
   
2.                 If wb.Sheets(j).Name = wb1.Sheets(i).Name Then
   
3.                     wb.Sheets(j).Copy After:=wb.Sheets(wb.Sheets.Count)
   
4.                     wb.Sheets(j).Delete
   
5.                     Exit For
   
6.                 End If
   
7.             Next
   
8.             wb1.Sheets(i).Copy After:=wb.Sheets(wb.Sheets.Count)

複製代碼

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

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

複製代碼

yangjie

回復 9# stillfish00
謝謝指導 OK 了