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>
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")
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
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
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
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
来源：https://stackoverflow.com/questions/17779408/ms-excel-do-not-copy-the-color-theme-automatically