在VBA中复制Excel源主题（仅格式化）

我试图在VBA中以编程方式将大量单元格从一个工作簿复制到另一个工作簿。我想复制格式（包括整个源主题）和值，但不复制公式。以下是我的VBA代码：

fromCells.Copy

toCells.PasteSpecial Paste:=xlPasteFormats
toCells.PasteSpecial Paste:=xlPasteColumnWidths
toCells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

Application.CutCopyMode = False

不幸的是，有时上面的代码不起作用。这通常与字体和大小有关。我注意到，每当发生这种情况时，复制字体格式的唯一方法就是使用

xlPasteAllUsingSourceTheme

，因此字体格式似乎以某种方式注册到了“源主题”。不幸的是，

xlPasteAllUsingSourceTheme

对我不起作用，因为它也在复制公式

那么，有没有一种方法可以将源主题（仅格式化）复制到另一个主题？或者是一种强制复制所有字体格式的方法

注意：使用

xlpasteAllisingSourceTheme

复制，然后用

xlPasteValues

覆盖，对我来说不起作用，因为复制公式时，它会不断弹出消息框，告诉我公式的问题（例如公式中使用的命名范围冲突等）

我正在使用Excel 2013。我注意到这个问题在Excel2007或更早版本中似乎没有出现。感谢您的帮助

---

编辑：我还尝试了以下代码（添加到上述代码的开头），但仍然不起作用

Dim themeTempFilePath As String
themeTempFilePath = Environ("temp") & "\" & fromWorkbook.Name & "Theme.xml"

fromWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
toWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
fromWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
toWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath

---

更新：上面保存和加载主题的代码似乎确实有效。我看到的有问题的文本来自另一个地方——表单控件。它是作为图片复制的（使用

Shape.CopyPicture

），但在复制过程中字体会发生变化。不过，我将把这个问题作为另一个问题发布

对于这个问题，我将使用主题保存和加载机制作为答案。

尝试1或2

Option Explicit

Public Sub copyWithoutFormulas_1()
    xlEnabled False
    With Sheet2
        .EnableCalculation = False
        .EnableFormatConditionsCalculation = False

        .UsedRange.EntireColumn.Delete
        Sheet1.UsedRange.Copy .Cells(1, 1)
        .UsedRange.Value2 = .UsedRange.Value2

        .EnableCalculation = True
        .EnableFormatConditionsCalculation = True
    End With
    Application.CutCopyMode = False
    xlEnabled True
End Sub

Public Sub copyWithoutFormulas_2()
    xlEnabled False
    Sheet1.Copy After:=Worksheets(Worksheets.Count)
    With Worksheets(Worksheets.Count).UsedRange
        .Value2 = .Value2
    End With
    xlEnabled True
End Sub

Private Sub xlEnabled(ByVal opt As Boolean)
    With Application
        .EnableEvents = opt
        .DisplayAlerts = opt
        .ScreenUpdating = opt
        .Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

---

要强制将源主题复制到目标单元格，可以执行以下操作。不幸的是，此方法将源主题应用于整个目标工作簿，在我的情况下这是可以的。不确定它是否对其他人有用

Sub CopyText(fromCells As Range, toCells As Range, Optional copyTheme As Boolean = False)
    If copyTheme Then
        Dim fromWorkbook As Workbook
        Dim toWorkbook As Workbook
        Dim themeTempFilePath As String

        Set fromWorkbook = fromCells.Worksheet.Parent
        Set toWorkbook = toCells.Worksheet.Parent
        themeTempFilePath = Environ("temp") & "\" & fromWorkbook.Name & "Theme.xml"

        fromWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
        toWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
        fromWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
        toWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
    End If

    Set toCells = toCells.Cells(1, 1).Resize(fromCells.Rows.Count, fromCells.Columns.Count)
    fromCells.Copy

    toCells.PasteSpecial Paste:=xlPasteFormats
    toCells.PasteSpecial Paste:=xlPasteColumnWidths
    toCells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    Application.CutCopyMode = False
End Sub

---

我试过你的第一种方法，但没用。复制的项目仍然没有正确格式化。至于你的第二种方法，我不想复制整个表单本身，只是其中的一部分。另外，我不想复制任何命名范围、嵌入对象、图片、图表等。我只想要单元格数据。您能在前后显示一些示例数据吗？同样的细胞是造成问题的还是随机的？不幸的是，很难重现问题。您需要使用Excel 2003创建工作簿，保存它，然后使用Excel 2013重新打开它。您还可以在Excel 2013中创建一个工作簿，并通过一个自定义的XML文件来更改其主题，该文件反映了Excel 2003的主题。