MS Excel do not copy the color theme automatically

Question

I am using MS Excel 2010 My Company uses a set of standard color scheme / theme for MS Excel 2010 .I gave it a name (companycolor). I have a template contains that color scheme and a macro in it to perform tasks. When I press macro button it makes a copy of activesheet,protect it and email it to intended recipient.Problem is that when macro makes a copy of activesheet into a new workbook it doesn't copy the color scheme / theme that template have, I mean with the my company color scheme (companycolor) due to which all cells color, color of charts and shapes get disturbed and changed according to Excel default color scheme which seems very odd. Do you have any way forward to overcome this issue or any suggestion in this regards

Here is the link of Snap Shot!, help you to understand my problem better *>>Here is the vba code that makes copy of active worksheet from active workbook into a new workbook, protect it and email it.***

Private Sub CommandButton2_Click()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

If (Range("AQ5") <> "") Or (Range("AQ6") <> "") Then
Range("A5").Select

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook
Application.ScreenUpdating = False

ActiveSheet.Copy

Range("A14").ClearContents
ActiveSheet.Protect Password:="1234567890"
Set Destwb = ActiveWorkbook

With Destwb
If Val(Application.Version) < 12 Then
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    If Sourcewb.Name = .Name Then
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        MsgBox "Your answer is NO in the security dialog"
        Exit Sub
    Else
        Select Case Sourcewb.FileFormat
        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
        Case 52:
            If .HasVBProject Then
                FileExtStr = ".xlsm": FileFormatNum = 52
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51
            End If
        Case 56: FileExtStr = ".xls": FileFormatNum = 56
        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
 End If
 End With

 TempFilePath = Environ$("temp") & "\"
 TempFileName = "DI Status for " & Range("A17") & " Dated " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
 On Error Resume Next
 With OutMail
    .To = Range("AQ6").Value
    .CC = Range("AQ7").Value
    .BCC = ""
    .Subject = Range("AQ8").Value
    .Body = Range("AQ9").Value
    .Attachments.Add Destwb.FullName
    .Display
    Application.Wait (Now + TimeValue("0:00:00"))
    Application.SendKeys "%s"

End With
On Error GoTo 0
.Close savechanges:=False
End With


Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Application.ScreenUpdating = True
Set Sourcewb = Nothing
Set Destwb = Nothing
Set OutApp = Nothing
Set OutMail = Nothing
MsgBox ("Project Status Has been Sent")
 Else
MsgBox "There must be atleast one contact in the To, or Cc, field"
End If

End Sub

Below is xml coding of color scheme which Microsoft excel save when you create any new color scheme / theme and it save the configuration file called xml file in the default path C:\Users\**UserName**\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors

so far i have reached to the conclusion that anyhow if we get able to incorporate that below xml code into the above vba code then we can get the desired result. But i dont know how.

<?xml version="1.0" encoding="UTF-8" standalone="true"?>
-<a:clrScheme name="mycompanytheme"
xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main">
-<a:dk1>
      <a:sysClr lastClr="000000" val="windowText"/>
</a:dk1>
-<a:lt1>
      <a:sysClr lastClr="FFFFFF" val="window"/>
</a:lt1>
-<a:dk2>
      <a:srgbClr val="1F497D"/>
</a:dk2>
-<a:lt2>
      <a:srgbClr val="EEECE1"/>
</a:lt2>
-<a:accent1>
      <a:srgbClr val="D60037"/>
</a:accent1>
-<a:accent2>
      <a:srgbClr val="B21DAC"/>
</a:accent2>
+<a:accent3>
      -<a:accent4><a:srgbClr val="FFCE00"/>
</a:accent4>
-<a:accent5>
      <a:srgbClr val="009DD9"/>
</a:accent5>
-<a:accent6>
      <a:srgbClr val="AF0637"/>
</a:accent6>
      -<a:hlink><a:srgbClr val="80076B"/>
</a:hlink>
      -<a:folHlink><a:srgbClr val="218535"/>
</a:folHlink>
</a:clrScheme>

Answer 1

Another, perhaps more elegant, solution would be taking the same template the ActiveWorkbook is using and applying it to the newly create workbook:

Set NewBook = Workbooks.Add("OriginalTemplate")

In this case 'OriginalTemplate' is the name of the template of the ActiveWorkbook

Answer 2

You can also try the following

'Copy current colorscheme to the new Workbook
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
Dim Destwb As Workbook
Set Destwb = ActiveWorkbook
For i = 1 To 56
  Destwb.Colors(i) = Sourcewb.Colors(i)
Next i

Answer 3

Finally I found a way to get it worked!

Describing solution so others can get help from this! Here is the conclusion and it worked! First of all by giving convenient path to the this vba code,paste it on the file that has any specific color scheme theme.

   ActiveWorkbook.Theme.ThemeColorScheme.Save("C:\myThemeColorScheme.xml")

The above code will generate an xml file in your specified path.

Then, paste the below line of code giving the same path where your xml file resided, above your "email sending" code.

ActiveWorkbook.Theme.ThemeColorScheme.Load("C:\myThemeColorScheme.xml")

Now it will it copy the theme in a new workbook.

By default the theme configuration reside on

"C:\Users\UserName\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\themefile.xml")

Answer 4

At the end of code you can call the below function which will set you color pallete for the activeworkbook. You need to adjust the RBG as per you company standard color theme.

 Sub SetColours()

        ActiveWorkbook.Colors(1) = RGB(140, 6, 12)
        ActiveWorkbook.Colors(2) = RGB(255, 255, 255)
        ActiveWorkbook.Colors(3) = RGB(255, 0, 0)
        ActiveWorkbook.Colors(4) = RGB(152, 196, 120)
        ActiveWorkbook.Colors(5) = RGB(0, 0, 255)
        ActiveWorkbook.Colors(6) = RGB(255, 215, 101)
        ActiveWorkbook.Colors(7) = RGB(248, 116, 122)
        ActiveWorkbook.Colors(8) = RGB(97, 176, 255)
        ActiveWorkbook.Colors(9) = RGB(128, 0, 0)
        ActiveWorkbook.Colors(10) = RGB(0, 128, 0)
        ActiveWorkbook.Colors(11) = RGB(19, 38, 78)
        ActiveWorkbook.Colors(12) = RGB(128, 128, 0)
        ActiveWorkbook.Colors(13) = RGB(128, 0, 128)
        ActiveWorkbook.Colors(14) = RGB(0, 128, 128)
        ActiveWorkbook.Colors(15) = RGB(192, 192, 100)
        ActiveWorkbook.Colors(16) = RGB(127, 114, 99)
        ActiveWorkbook.Colors(17) = RGB(153, 153, 255)
        ActiveWorkbook.Colors(18) = RGB(153, 51, 102)
        ActiveWorkbook.Colors(19) = RGB(255, 255, 204)
        ActiveWorkbook.Colors(20) = RGB(204, 255, 255)
        ActiveWorkbook.Colors(21) = RGB(102, 0, 102)
        ActiveWorkbook.Colors(22) = RGB(255, 128, 128)
        ActiveWorkbook.Colors(23) = RGB(0, 102, 204)
        ActiveWorkbook.Colors(24) = RGB(225, 225, 255)
        ActiveWorkbook.Colors(25) = RGB(0, 0, 128)
        ActiveWorkbook.Colors(26) = RGB(255, 0, 255)
        ActiveWorkbook.Colors(27) = RGB(255, 255, 0)
        ActiveWorkbook.Colors(28) = RGB(0, 255, 255)
        ActiveWorkbook.Colors(29) = RGB(128, 0, 128)
        ActiveWorkbook.Colors(30) = RGB(128, 0, 0)
        ActiveWorkbook.Colors(31) = RGB(0, 128, 128)
        ActiveWorkbook.Colors(32) = RGB(0, 0, 255)
        ActiveWorkbook.Colors(33) = RGB(131, 162, 225)
        ActiveWorkbook.Colors(34) = RGB(204, 255, 255)
        ActiveWorkbook.Colors(35) = RGB(204, 255, 204)
        ActiveWorkbook.Colors(36) = RGB(255, 255, 153)
        ActiveWorkbook.Colors(37) = RGB(153, 204, 255)
        ActiveWorkbook.Colors(38) = RGB(255, 153, 204)
        ActiveWorkbook.Colors(39) = RGB(204, 153, 255)
        ActiveWorkbook.Colors(40) = RGB(255, 204, 153)
        ActiveWorkbook.Colors(41) = RGB(51, 102, 255)
        ActiveWorkbook.Colors(42) = RGB(51, 204, 204)
        ActiveWorkbook.Colors(43) = RGB(153, 204, 0)
        ActiveWorkbook.Colors(44) = RGB(234, 148, 118)
        ActiveWorkbook.Colors(45) = RGB(255, 153, 0)
        ActiveWorkbook.Colors(46) = RGB(255, 102, 0)
        ActiveWorkbook.Colors(47) = RGB(102, 102, 153)
        ActiveWorkbook.Colors(48) = RGB(199, 190, 182)
        ActiveWorkbook.Colors(49) = RGB(0, 51, 102)
        ActiveWorkbook.Colors(50) = RGB(51, 153, 102)
        ActiveWorkbook.Colors(51) = RGB(40, 70, 55)
        ActiveWorkbook.Colors(52) = RGB(225, 168, 0)
        ActiveWorkbook.Colors(53) = RGB(212, 81, 33)
        ActiveWorkbook.Colors(54) = RGB(204, 160, 123)
        ActiveWorkbook.Colors(55) = RGB(98, 52, 72)
        ActiveWorkbook.Colors(56) = RGB(0, 0, 40)

    End Sub

Answer 5

Use PasteSpecial Method.

 With Range("A1:K1")
     .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
     SkipBlanks:=False, Transpose:=False
     Application.CutCopyMode = False
 End With

Refer this Link for more about PasteSpecial