所有工作表的 VBA 复制和粘贴格式

Question

我尝试编写非常简单的脚本来复制原始工作表 (ORIGINAL_NOCHANGE) 并仅粘贴其他工作表的格式。 在 ORIGINAL_NOCHANGE 中，有些列合并在一起，有些列具有条件格式。

这是 ORIGINAL_NOCHANGE 的原始结构：

COPY1 和 COPY2 是 ORIGINAL_NOCHANGE 的副本，但没有原始格式（我的 Python 脚本无法复制 Excel 格式）。

在我运行我的 VBA 脚本之后：

Sub TrySecond()
        
        Dim ws As Worksheet
        
        'Worksheets("ORIGINAL_NOCHANGE").Activate
        Worksheets("ORIGINAL_NOCHANGE").Range("A1:AA71").Copy
        
        For Each ws In Worksheets
            If ws.Name <> "ORIGINAL_NOCHANGE" Then
                    'ws.Range("AC1") = "Are You Kidding Me"
                    Range("A1:P17").Select
                    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            End If
        Next
End Sub

ORIGINAL_NOCHANGE 已更改为这种结构，我真的不想要：

但是在 COPY1 和 COPY2 中什么也没发生！

请注意，我的 python 脚本将复制数百个 ORIGINAL_NOCHANGE 工作表，但由于内部包的限制，它无法复制格式。 放在这里可能有人建议我手动复制原件。

我不确定我的脚本有什么错误。你能帮忙吗？

非常感谢！

Answer 1

新工作表的格式

• 调整常量部分（和工作簿）中的值。

Option Explicit

Sub FormatsToNewWorksheets()
    
    ' Define constants.
    Const sName As String = "ORIGINAL_NOCHANGE"
    Const dNamesList As String = "COPY1,COPY2"
    
    ' Create a reference to the workbook containing this code.
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Create a reference to the Source Worksheet.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    ' Write the names from the list to the Destination Names Array.
    Dim dNames() As String: dNames = Split(dNamesList, ",")
    
    ' Declare additional variables.
    Dim dws As Worksheet ' (Current) Destination Worksheet
    Dim n As Long ' Destination Names Counter
    
    ' Loop through the elements (names) of the Destination Names Array.
    For n = 0 To UBound(dNames)
        ' Attempt to create a reference to the (current) Destination Worksheet.
        On Error Resume Next
        Set dws = wb.Worksheets(dNames(n))
        On Error GoTo 0
        ' Delete the (current) Destination Worksheet if it exists.
        If Not dws Is Nothing Then ' exists
            Application.DisplayAlerts = False
            dws.Delete
            Application.DisplayAlerts = True
        'Else ' doesn't exist
        End If
        ' Create the (current) Destination Worksheet
        ' (a copy of the Source Worksheet)
        ' after all existing sheets (at the last position).
        sws.Copy After:=wb.Sheets(wb.Sheets.Count)
        ' Modify the (current) Destination Worksheet.
        With ActiveSheet
            .Name = dNames(n)
            .UsedRange.ClearContents ' or not?
        End With
    Next n

End Sub

Answer 2

右键单击您的工作表，然后选择Move or Copy，然后勾选create a copy，然后您可以使用相同格式创建任意数量的工作表，无需VBA ....您也可以将此工作表创建到其他工作簿....

如果你还是喜欢VBA代码，这里是你可以使用的函数，和我刚才做的一样：

Sub Macro1()

    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy After:=Sheets(1)
End Sub