Solved: Transfer new Color Scheme to Existing

[shades]

Howdy.

I have developed a new color scheme (adapted and changed from Charley Kyd's Color Scheme (http://www.exceluser.com/explore/anycolor.htm); see attached for my revision. I have this also saved as a template and in XLStart so that every new workbook is based on it. And our entire Marketing department (~2000 people) is gradually moving to using it.

One issue that came up is how to transfer this color scheme to an existing workbook. Can it be done? Is VBA the only route to go?

[Simon Lloyd]

I may be going too simple here, but wouldn't it be better to copy and paste values, number formats and formulas to a new workbook that you start already having the colour scheme rather than trying to apply the colours to the existing?

Regards,
Simon

[malik641]

Howdy.

I have developed a new color scheme (adapted and changed from Charley Kyd's Color Scheme (http://www.exceluser.com/explore/anycolor.htm); see attached for my revision. I have this also saved as a template and in XLStart so that every new workbook is based on it. And our entire Marketing department (~2000 people) is gradually moving to using it.

One issue that came up is how to transfer this color scheme to an existing workbook. Can it be done? Is VBA the only route to go?
Try Tools --> Options... --> Color --> Copy Colors From (dropdown) --> Color Scheme.xls

But the color scheme.xls has to be open...as well as the workbook copying to.

HTH

BTW: XL 2003, not sure about lower versions though.

[malik641]

And for VBA to do it... (thanks to Ivan and MVIDAS for the functions)

Option Explicit
Sub ChangeColors()
Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook

Dim sPath As String
Dim vsArray() As String
Dim i As Long

ReDim vsArray(0)
sPath = "C:\Test Files\"

Call ReturnAllFileDir(sPath, vsArray())

If Not IsError(vsArray(0)) Then
For i = 0 To UBound(vsArray())
If vsArray(i) Like "*.xls" Then
If FileIsOpen(vsArray(i)) = False Then
Set xlWB = xlApp.Workbooks.Open(vsArray(i))
xlWB.Colors = ThisWorkbook.Colors
xlWB.Save
xlWB.Close
End If
End If
Next i
End If
xlApp.Quit
End Sub
Function ReturnAllFileDir(ByVal vPath As String, ByRef vsArray() As String) As Boolean
' Function thanks to Mvidas from www.VBAExpress.com (http://www.VBAExpress.com)
Dim tempStr As String, vDirs() As String, Cnt As Long, dirCnt As Long

If Len(vsArray(0)) = 0 Then
Cnt = 0
Else
Cnt = UBound(vsArray) + 1
End If
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
On Error GoTo BadDir
tempStr = Dir(vPath, 31)

Do Until Len(tempStr) = 0
If Asc(tempStr) <> 46 Then
If GetAttr(vPath & tempStr) And vbDirectory Then
ReDim Preserve vDirs(dirCnt)
vDirs(dirCnt) = tempStr
dirCnt = dirCnt + 1
End If
BadDirGo:
End If
tempStr = Dir
SkipDir:
Loop
On Error GoTo BadFile
tempStr = Dir(vPath, 15)
Do Until Len(tempStr) = 0
ReDim Preserve vsArray(Cnt)
vsArray(Cnt) = vPath & tempStr
Cnt = Cnt + 1
tempStr = Dir
Loop
Debug.Print Cnt
BadFileGo:
On Error GoTo 0
If dirCnt > 0 Then
For dirCnt = 0 To UBound(vDirs)
If Len(Dir(vPath & vDirs(dirCnt))) = 0 Then
ReturnAllFileDir vPath & vDirs(dirCnt), vsArray
End If
Next
End If
Exit Function
BadDir:
If tempStr = "pagefile.sys" Or tempStr = "???" Then
' Debug.Print "DIR: Skipping: " & vPath & tempStr
Resume BadDirGo
ElseIf Err.Number = 52 Then 'or err.number=5 then
' Debug.Print "No read rights: " & vPath & tempStr
Resume SkipDir
End If
Debug.Print "Error with DIR (BadDir): " & Err.Number & " - " & Err.Description
Debug.Print " vPath: " & vPath
Debug.Print " tempStr: " & tempStr
Exit Function
BadFile:
If Err.Number = 52 Then 'or err.number=5 then
' Debug.Print "No read rights: " & vPath & tempStr
Else
Debug.Print "Error with DIR (BadFile): " & Err.Number & " - " & Err.Description
Debug.Print " vPath: " & vPath
Debug.Print " tempStr: " & tempStr
End If
Resume BadFileGo
End Function
Public Function FileIsOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// http://www.xcelfiles.com
Dim hdlFile As Long
'// Error is generated if you try
'// opening a File for ReadWrite lock >> MUST BE OPEN!
On Error GoTo FileIsOpen:
hdlFile = FreeFile
Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
FileIsOpen = False
Close hdlFile
Exit Function
FileIsOpen:
'// Someone has it open!
FileIsOpen = True
Close hdlFile
End Function

:)

[shades]

Wow, thanks, guys! I am using XL2003, but most of our people use XL2002. I will try the manual method first (Works). Although, this could involve thousands of xls files, not including the entire Marketing Dept, so the VBA may be the way to go.

[malik641]

Let us know :thumb

[shades]

Try Tools --> Options... --> Color --> Copy Colors From (dropdown) --> Color Scheme.xls

But the color scheme.xls has to be open...as well as the workbook copying to.

HTH

BTW: XL 2003, not sure about lower versions though.

Got to admit, this was one of those forehead slapping moments... :doh: I feel rather like a beginner in not coming up with this on my own. I claim senioritis and its attendant problems! :rotlaugh:

Yes, this worked well, and I have have passed it on to others in my department.


Thanks again. I hope to have time this coming week to try the code you provided.

[malik641]

I was wondering how you may have missed it...I figured maybe it wasn't available for lower versions than xl2003.

But hey, it happens :yes I'm still smacking myself for posting too quickly and forgetting to delete something in the post :doh:

I ran the test on about 12 files and it was pretty quick....I'm curious to know how fast it could convert all the files for ya. Hope you get time to do it, too. :thumb

The longest part of the code is the collecting of the files and putting them into an array...I use it in conjunction with a progress bar form so I know approximately how long it will take (I have to manually put the amount of files in the code because I still haven't found an instant way to find the number of total files of a folder and it's subfolders and the subfolders of subfolders and etc etc).