備份檔案

vinejason

平安
以下代碼可以按日期備份檔案
一個問題請教
假如這個檔案有許多Sheet
我只想另存Sheet(3,5,6,10,11,12,14,15)
可以做到嗎 ?

Sub Backup ()
PAF = MsgBox("要備份資料嗎?", vbYesNo + vbQuestion, "訊息視窗")
      If PAF = vbYes Then
      Application.StatusBar = "檔案備份中,敬請稍候!"
FileDate = Format(Date, "yyyymmdd")  ' 年月日格式共8個數字(備份)
ActiveWorkbook.SaveCopyAs filename:= _
"\\Web_server\pcmac交換區\發行\備份\" & FileDate & ".xls"

Else
        MsgBox "再見 !", vbOKOnly + vbInformation, "訊息視窗"
        End If
end sub

GBKEE

回復 1# vinejason

1. Option Explicit
   
2. Sub Backup()
   
3.     Dim FileDate As String
   
4.        If MsgBox("要備份資料嗎?", vbYesNo + vbQuestion, "訊息視窗") = vbYes Then
   
5.         Application.StatusBar = "檔案備份中,敬請稍候!"
   
6.         With ActiveWorkbook.Sheets(Array(3, 5, 6, 10, 11, 12, 14, 15)).Copy
   
7.         'With ActiveWorkbook              為作用是視窗中的活頁簿
   
8.         '可改成 With ThisWorkbook         為程式碼所在的活頁簿
   
9.         '可改成 With Workbooks("TEST.XLS")為指定的活頁簿
   
10.             FileDate = Format(Date, "yyyymmdd")  ' 年月日格式共8個數字(備份)
    
11.             ActiveWorkbook.Close True, Filename:="\\Web_server\pcmac交換區\發行\備份\" & FileDate & ".xls"
    
12.             '這裡的ActiveWorkbook 不可改
    
13.             '.Copy後的活頁簿為ActiveWorkbook
    
14.         End With
    
15.     Else
    
16.         MsgBox "再見 !", vbOKOnly + vbInformation, "訊息視窗"
    
17.     End If
    
18. End Sub

複製代碼

vinejason

回復 2# GBKEE
Gbkee 平安
這樣也可以做得到 !
真棒
感謝您的回覆
祝福您天天被喜樂包圍

vinejason

回復 2# GBKEE
GBKEE 平安
備份後的Sheet 相當完整 !

再請教
可以把備份檔案 Sheet裡的程式碼 , 取消或刪除嗎?

GBKEE

回復 4# vinejason

1. Sub Backup()
   
2.     Dim FileDate As String
   
3.        If MsgBox("要備份資料嗎?", vbYesNo + vbQuestion, "訊息視窗") = vbYes Then
   
4.         Application.StatusBar = "檔案備份中,敬請稍候!"
   
5.        Application.DisplayAlerts = False
   
6.         With ActiveWorkbook.Sheets(Array(3, 5, 6, 10, 11, 12, 14, 15)).Copy
   
7.         'With ActiveWorkbook              為作用是視窗中的活頁簿
   
8.         '可改成 With ThisWorkbook         為程式碼所在的活頁簿
   
9.         '可改成 With Workbooks("TEST.XLS")為指定的活頁簿
   
10.             FileDate = Format(Date, "yyyymmdd")  ' 年月日格式共8個數字(備份)
    
11.             
    
12.             ActiveWorkbook.SaveAs Filename:="\\Web_server\pcmac交換區\發行\備份\" & FileDate & ".xls", FileFormat:=xlXMLSpreadsheet
    
13.             '**********************************
    
14.             '2003版:活頁簿的檔案格式及 (或) 類型。  FileFormat:=xlXMLSpreadsheet 指定為 Sheet裡沒有程式碼的類型
    
15.             '********************************
    
16.             
    
17.             ActiveWorkbook.Close
    
18.             '這裡的ActiveWorkbook 不可改
    
19.             '.Copy後的活頁簿為ActiveWorkbook
    
20.         End With
    
21.     Else
    
22.         MsgBox "再見 !", vbOKOnly + vbInformation, "訊息視窗"
    
23.     End If
    
24.    Application.DisplayAlerts = True
    
25. End Sub

複製代碼

vinejason

回復 5# GBKEE
GBKEE 平安
謝謝您仔細的回覆
智慧人大有能力 , 有知識的人力上加力

yangjie

回復 5# GBKEE
請教GBKEE
我參考您的
Sub Backup()
    Dim FileDate As String
    Set wb = ThisWorkbook
    wb.Activate
    If MsgBox("要備份資料嗎?", vbYesNo + vbQuestion, "訊息視窗") = vbYes Then
         Application.DisplayAlerts = False
        'With ActiveWorkbook.Sheets(Array(1, 3)).Copy     將此列改成紅色一列就不通嘞
        With ActiveWorkbook.copy
            FileDate = Format(Date, "yyyymmdd")
            ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\資料庫\" & FileDate & ".xls"
            Application.EnableEvents = False
            ActiveWorkbook.Close True
            Application.EnableEvents = True
        End With
    Else
        MsgBox "再見 !", vbOKOnly + vbInformation, "訊息視窗"
    End If
    Application.DisplayAlerts = True
End Sub
應如何  作
在wb中用vba
使原wb  copy成  wb1      然後 wb1.close  (這一段我不會，try很久嘞)
回wb 再做第二

yangjie

回復 7# yangjie
感謝GBKEE  
我參考這次與前13.14頁的檔案複製與sheets另存新檔
我的問題解決了
Sub Backup()
    Dim FileName1 As String
    Set wb = ThisWorkbook
    wb.Activate
    Dim str1 As String
    Dim ar() As String
    n = Sheets("基本資料").Cells(1, 60).End(xlToLeft).Column - 5
    If n <= 0 Then Exit Sub
    ReDim ar(n)
    For i = 1 To n
        ar(i - 1) = Sheets("基本資料").Cells(1, i + 5)
    Next
    str1 = Sheets("基本資料").Cells(1, 1) & Sheets("基本資料").Cells(1, 2)
    If MsgBox("要備份資料嗎?", vbYesNo + vbQuestion, "訊息視窗") = vbYes Then
        Application.DisplayAlerts = False
        For i = 1 To n
            FileName1 = ThisWorkbook.Path & "\" & str1 & "學期(" & ar(i - 1) & ")出缺勤暨獎懲登錄.xls"
            With ActiveWorkbook
                ActiveWorkbook.SaveCopyAs FileName:=FileName1    '漂亮
            End With
        Next
    Else
        MsgBox "再見 !", vbOKOnly + vbInformation, "訊息視窗"
    End If
    Application.DisplayAlerts = True
  End Sub