CODEWITHSUNDEEP
vbaexcelexcel-2013
SF Lee
SF Lee

Reputation: 1777

Copying Excel source theme (formatting only) in VBA

I'm trying to programmatically copy a large range of cells from one workbook to another in VBA. I want to copy the formatting (including the entire source theme) and values, but NOT formulas. The following is my VBA code:

fromCells.Copy

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

Application.CutCopyMode = False

Unfortunately, there are occasions when the above code doesn't work. This is usually with Font face and size. I noticed that whenever this happens, the only way to copy the font formatting across is to use xlPasteAllUsingSourceTheme, so it seems the font formatting is somehow registered to a 'source theme'. Unfortunately, xlPasteAllUsingSourceTheme doesn't work for me because it's copying formulas as well.

So is there a way to copy the source theme (formatting only) across? Or maybe a way to force copy all the font formatting across?

Note: Copying using xlPasteAllUsingSourceTheme and then overwriting it with xlPasteValues won't work for me because when the formulas is copied it keeps popping up message boxes telling me about issues with the formulas (such as conflicting named ranges used in the formulas, etc.).

I'm using Excel 2013. I noticed this problem doesn't seem to arise in Excel 2007 or earlier. Any help is appreciated.

Edit: I've also tried the following code (added to the beginning of the above code), it still doesn't work...

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

Update: It seems the above code for saving and loading themes does work. The problematic text that I was looking at came from a different place - a form control. It was copied as a picture (using Shape.CopyPicture) but somehow the font gets changed in the process. However, I'll post this issue as another question.

For this question, I'll put up the theme saving and loading mechanism as an answer.

Upvotes: 1

Views: 5230

Answers (2)

SF Lee
SF Lee

Reputation: 1777

To force copy the source theme to the destination cells, one can do the following. Unfortunately, this method will apply the source theme to the entire destination workbook, which is OK in my situation. Not sure if it's useful for anyone else.

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

Upvotes: 1

paul bica
paul bica

Reputation: 10715

Try 1 or 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

Upvotes: 1

Related Questions