[英]copy more than one sheets using VBA macro
我是 VBA 的初学者,我需要执行以下操作。 从工作簿开始,我应该创建另一个没有公式和宏代码的工作簿。
我找到了一些解决方案,并在此基础上对自己的代码进行了建模:
Sub SaveValuesOnly()
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String
sPath = "C:\Users\"
sFileName = "OVERALL RECAP"
Set wsCopy = ThisWorkbook.Worksheets("INCIDENTS")
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)
wsCopy.Cells.copy
wsPaste.Cells.PasteSpecial xlPasteValues
wsPaste.Cells.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
wsPaste.Name = "Expenses" 'Change if needed
wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
End Sub
我需要复制多张纸并尝试使用官方文档,例如:
Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
With ActiveWorkbook
.SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
但是我没有设法在上面的代码中实现这一点,有什么建议吗? 谢谢。
流动
基本上,该程序将:
ThisWorkbook
(包含此代码的工作簿)的副本,.xlsx
格式的新工作簿中,评论
OVERALL RECAP
)已经打开,它将崩溃Excel
。编码
Option Explicit
Sub copyWorksheets()
Const dPath As String = "C:\Users"
Const dFileName As String = "OVERALL RECAP"
Const CopyList As String = "INCIDENTS,Sheet2,Sheet3"
Const PasteList As String = "Expenses,Sheet2,Sheet4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim CopyNames() As String: CopyNames = Split(CopyList, ",")
Dim PasteNames() As String: PasteNames = Split(PasteList, ",")
Dim nUpper As Long: nUpper = UBound(CopyNames)
Dim tFilePath As String: tFilePath = dPath & "\" & "t_" & wb.Name
Application.ScreenUpdating = False
' Save a copy.
wb.SaveCopyAs tFilePath
' Work with the copy.
With Workbooks.Open(tFilePath)
' Copy values (remove formulas).
Dim n As Long
For n = 0 To nUpper
With .Worksheets(CopyNames(n)).UsedRange
.Value = .Value
End With
Next n
' Delete other sheets.
Dim dCount As Long: dCount = .Sheets.Count - nUpper - 1
If dCount > 0 Then
Dim DeleteNames() As String: ReDim DeleteNames(1 To dCount)
Dim sh As Object ' There maybe e.g. charts.
n = 0
For Each sh In .Sheets
If IsError(Application.Match(sh.Name, CopyNames, 0)) Then
n = n + 1
DeleteNames(n) = sh.Name
End If
Next sh
Application.DisplayAlerts = False
.Sheets(DeleteNames).Delete
Application.DisplayAlerts = True
End If
' Rename worksheets.
For n = 0 To nUpper
If CopyNames(n) <> PasteNames(n) Then
.Worksheets(CopyNames(n)).Name = PasteNames(n)
End If
Next n
' Save workbook.
.Worksheets(1).Activate
Application.DisplayAlerts = False
.SaveAs _
Filename:=dPath & "\" & dFileName, _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'.Close SaveChanges:=False ' Close the new workbook.
End With
' Delete the copy.
Kill tFilePath
Application.ScreenUpdating = True
MsgBox "Workbook created.", vbInformation, "Success"
'wb.Close SaveChanges:=False ' Close ThisWorkbook.
End Sub
下面的代码采用与前面代码相反的方法。 它将整个工作簿复制到一个新名称,然后对其进行修改。 您可以列出要保留的工作表。 其中的公式将转换为它们的值。 未列出的工作表将被删除。
Sub SaveValuesOnly()
' 154
' list the sheets you want to keep by their tab names
Const SheetsToKeep As String = "Sheet1,Sheet3"
Dim sFileName As String
Dim sPath As String
Dim Wb As Workbook ' the new workbook
Dim Ws As Worksheet ' looping object: worksheet
Dim Keep() As String ' array of SheetsToKeep
Dim i As Long ' loop counter: Keep index
sPath = Environ("UserProfile") & "\Desktop\"
sFileName = "OVERALL RECAP"
Keep = Split(SheetsToKeep, ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' create a copy of the ActiveWorkbook under a new name
ActiveWorkbook.SaveCopyAs sPath & sFileName & ".xlsm"
Set Wb = Workbooks.Open(sPath & sFileName & ".xlsm")
For Each Ws In Wb.Worksheets
' check if the sheet is to be kept
For i = UBound(Keep) To 0 Step -1
If StrComp(Ws.Name, Trim(Keep(i)), vbTextCompare) = 0 _
Then Exit For
Next i
If i = True Then ' True = -1
Ws.Delete
Else
' keep the sheet
With Ws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
' you can repeat PasteSpecial here to copy more detail
End With
End If
Next Ws
' change the file format to xlsx (deleting copy of this code in it)
Wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
Kill sPath & sFileName & ".xlsm"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
您需要注意几点。 一,ActiveWorkbook 将被复制。 这被假定为ThisWorkbook
(包含代码的那个),但它可能是任何其他的。 第二,在sPath
指定的位置已经存在的目标名称的任何工作簿都将被覆盖而不会发出警告。 第三,在代码运行时关闭警报。 如果它发生崩溃,它们将保持关闭状态,直到您重新启动 Excel 或在即时 window 中输入Application.DisplayAlerts = True
[Enter]。
最后但并非最不重要的一点是,工作表按其索引号的顺序(从左到右)进行处理。 如果保留工作表中的公式引用了工作表中被删除的数据,则序列很重要。 您可能必须运行两个循环,而不是我的代码中的一个。 使用一个循环来替换公式,另一个只是删除。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.