複製Excel工作表到一個新的工作簿值

Question

當前代碼：

Private Sub cmdsave_Click() 
Dim iRow As Long 
Dim ws As Worksheet 
Set ws = Worksheets("payin") 

'find first empty row in database 
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _ 
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1 

'copy the data to the database 


With ws 

.Cells(iRow, 1).Value = Me.txtlbp.Value 
.Cells(iRow, 2).Value = Me.txtdollar.Value 
.Cells(iRow, 3).Value = Me.txtsyp.Value 

End With 

'clear the data 
Me.txtlbp.Value = "" 
Me.txtdollar.Value = "" 
Me.txtsyp.Value = "" 

ActiveWorkbook.Save 

Dim savedate 
savedate = Date 
Dim savetime 
savetime = Time 
Dim formattime As String 
formattime = Format(savetime, "hh.MM.ss") 
Dim formatdate As String 
formatdate = Format(savedate, "DD-MM-YYYY") 

Application.DisplayAlerts = False 

If Len(Dir("D:\cashbackup\english", vbDirectory)) = 0 Then 
MkDir "D:\cashbackup\english" 
End If 

Dim backupfolder As String 
backupfolder = "D:\cashbackup\english\" 
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & "payin" & formatdate & " " & formattime & " " & ActiveWorkbook.Name 
Application.DisplayAlerts = False 
txtlbp.SetFocus 

End Sub 

當前代碼保存整個文件的副本複製到目錄「d：\ cashbackup \英語」，它走的是一條磁盤空間很大（每個保存點擊大約3.73 MB），其中只保存工作表：payin，payout和balance僅作爲值，而不用以前在excel項目文件中的excel單元格中創建的公式將節省硬盤空間（每次保存點擊不超過20 KB）

我需要：

我希望代碼保存一個僅包含特定工作表的新工作簿：payin，payout和balance作爲目錄中的值：「D：\ cashbackup \ english」，具有相同的文件命名，我的意思是沒有表單BOX中的用戶表單，沒有宏

先謝謝您。

Answer 1

新版本，但請記住：該網站不是找到工作的人的地方，而是尋找編寫代碼的幫助的地方......或者是一個起點。宏使用打開的文件，使：

• 刪除未列入「名單」
• 張刪除
• 把所有的細胞保護模式
• 公式添加密碼的所有工作表
• 保存與密碼（用於打開&修改）
• 從文件中刪除宏（在XLSX保存）

代碼：

Application.DisplayAlerts = False 
For Each xx In ActiveWorkbook.Sheets 
    If xx.Name = "Sheet1" Or xx.Name = "Sheet3" Then 
     xx.Select 
     Cells.Select 
     Selection.Copy 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     Selection.Locked = True 

     ActiveSheet.Protect Password:="ShPwd", DrawingObjects:=True, Contents:=True, Scenarios:=True 
    Else 
     xx.Delete 
    End If 
Next 
tmp = " - " & Format(Date, "DD-MM-YYYY") & " - " & Format(Time, "HH-MM-SS") 
ActiveWorkbook.Protect Password:="ShPwd", Structure:=True, Windows:=False 
ActiveWorkbook.SaveAs Filename:="E:\0\New folder\aa" & tmp & ".xlsx", FileFormat:= _ 
    xlOpenXMLWorkbook, CreateBackup:=False, Password:="Open" _ 
    , WriteResPassword:="Modify" 
ActiveWindow.Close 
Application.DisplayAlerts = True