Hi,

I am trying to copy formulas and formats from one workbook (source) to
another workbook (target). I discovered that the source book doesn't have
its sheets in numerical order and some are missing. In other words, you
might have Sheet1("FirstSheet"), Sheet4("SecondSheet"),
Sheet3("ThirdSheet"), [Sheet2 doesn't exist.] and so on.

I believe I need to work with the names instead of sheet numbers.

To get myself started, I recorded the following macro:

Sub Macro1()
'
Windows("SourceBook.xls").Activate
Sheets("SourceSheet").Select
Cells.Select
Range("A3").Activate
Selection.Copy
Windows("TargetBook.xls").Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
End Sub

From that, I created the following macro:

Public Sub CopyContentsFormat(lMin As Long, lMax As Long)
Dim index As Long
For index = lMin To lMax
'\This line below doesn't work - see explanation
Windows("SourceBook.xls").Worksheets(index).Cells. Copy
Windows("SourceBook.xls").Worksheets("Sheet" & index).Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
'\How do I copy/transfer the sheet names from the source book to the
'\ target book?
Next index
End Sub

I get the following error for the line that does not work:

Run-Time Error '438'
Object doesn't support this property or method.

When it didn't work, the index was 2, which was lmin. Sheet2 does exist.
So I am not sure what went wrong. But as mentioned above, I think I need to
work with the sheet names anyway, because of missing Sheet numbers and the
sheet order. I think I need to read the sheetnames into an array, and then
work with the sheet names?

Also, I would like to transfer the sheet names from the source book to the
target book. Any help is most appreciated.

Best regards,
Kevin

Dim sh as Worksheet, sh1 as Worksheet, Sh2 as Worksheet
Dim sh3 as Worksheet
Dim i as Long
i = 100
' rename destination sheets with dummy names to
' avoid duplicate sheet name problems
for each sh3 in workbooks("DestBook.xls").Worksheets
sh3.Name = "zxaabir" & i
i = i + 1
Next
sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls")
sh.cells.copy
sh1.Cells.PasteSpecial xlFormats
sh1.Cells.PasteSpecial xlFormulas
sh1.Name = sh.Name
set sh2 = Nothing
On Error Resume Next
set sh2 = sh1.Next
On Error goto 0
if not sh2 is nothing then
set sh1 = sh2
else
set sh1 = worksheets.Add(After:=sh1.Parent.Worksheets( _
sh1.Parent.Worksheets.count))
end if
Next

--
Regards,
Tom Ogilvy


"Kevin H. Stecyk" wrote in message
...
Hi,

I am trying to copy formulas and formats from one workbook (source) to
another workbook (target). I discovered that the source book doesn't have
its sheets in numerical order and some are missing. In other words, you
might have Sheet1("FirstSheet"), Sheet4("SecondSheet"),
Sheet3("ThirdSheet"), [Sheet2 doesn't exist.] and so on.

I believe I need to work with the names instead of sheet numbers.

To get myself started, I recorded the following macro:

Sub Macro1()
'
Windows("SourceBook.xls").Activate
Sheets("SourceSheet").Select
Cells.Select
Range("A3").Activate
Selection.Copy
Windows("TargetBook.xls").Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
End Sub

From that, I created the following macro:

Public Sub CopyContentsFormat(lMin As Long, lMax As Long)
Dim index As Long
For index = lMin To lMax
'\This line below doesn't work - see explanation
Windows("SourceBook.xls").Worksheets(index).Cells. Copy
Windows("SourceBook.xls").Worksheets("Sheet" & index).Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone,
_
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
'\How do I copy/transfer the sheet names from the source book to
the
'\ target book?
Next index
End Sub

I get the following error for the line that does not work:

Run-Time Error '438'
Object doesn't support this property or method.

When it didn't work, the index was 2, which was lmin. Sheet2 does exist.
So I am not sure what went wrong. But as mentioned above, I think I need
to
work with the sheet names anyway, because of missing Sheet numbers and the
sheet order. I think I need to read the sheetnames into an array, and
then
work with the sheet names?

Also, I would like to transfer the sheet names from the source book to the
target book. Any help is most appreciated.

Best regards,
Kevin

Hi Tom,

Thank you for the excellent answer! I took me a while to understand your
code.

I will try your routine tomorrow and single step through it to make sure my
understanding is correct.

Again, thank you for taking the time and effort to respond.

Best regards,
Kevin

Tom Ogilvy wrote...

Dim sh as Worksheet, sh1 as Worksheet, Sh2 as Worksheet
Dim sh3 as Worksheet
Dim i as Long
i = 100
' rename destination sheets with dummy names to
' avoid duplicate sheet name problems
for each sh3 in workbooks("DestBook.xls").Worksheets
sh3.Name = "zxaabir" & i
i = i + 1
Next
sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls")
sh.cells.copy
sh1.Cells.PasteSpecial xlFormats
sh1.Cells.PasteSpecial xlFormulas
sh1.Name = sh.Name
set sh2 = Nothing
On Error Resume Next
set sh2 = sh1.Next
On Error goto 0
if not sh2 is nothing then
set sh1 = sh2
else
set sh1 = worksheets.Add(After:=sh1.Parent.Worksheets( _
sh1.Parent.Worksheets.count))
end if
Next

--
Regards,
Tom Ogilvy

Hi Tom,

Your subroutine worked wonderfully. As I single stepped through it, I found
two small oversights.

sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls")

shold be changed to...

Set sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls").Worksheets

Once I installed this subrountine, I discovered these very quickly and
easily. I am mentioning it here for others that might borrow your same
routine.

I have modified your code with my normal syntax and have shown it below.

I have two additional questions:

(1) Did I use the correct code/syntax for assigning tab color? It seems to
work, and thus I think it is okay. But I am not sure about "color" versus
"colorindex". I have indicated that this is a '\New Line. So it should be
easy to spot.

(2) The subrountine adds an additional and unnecessary sheet to the
destination workbook. My last line prior to the end of the subrountine
removes a sheet. Did I use the best method? Is there an easier or more
direct method? As I suspect the last sheet should likely have the largest
sheet number, is there a way to select the "max sheet" or is the method
shown perfectly acceptable?

Thank you so much for all your help.

Best regards,
Kevin

Shown below is the modified subrountine. It copies the formulas and formats
from all the sheets in SourceBook to DestBook. We are having difficulty
(corruption) with the SourceBook and thus want its contents transferred. I
recognize that copying the "formats" potentially infects the
DestinationBook.



Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim lTotalSheetsDest As Long
Dim sSourceBook As String
Dim sDestBook As String

sSourceBook = "Source.xls"
sDestBook = "Dest.xls"

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)

For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color '\New Line

Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 = Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If

Next wksSheet2

'\New Line Below
Workbooks(sDestBook).Worksheets(Workbooks(sDestBoo k).Worksheets.Count).Delete

End Sub


"Tom Ogilvy" wrote in message
...

Dim sh as Worksheet, sh1 as Worksheet, Sh2 as Worksheet
Dim sh3 as Worksheet
Dim i as Long
i = 100
' rename destination sheets with dummy names to
' avoid duplicate sheet name problems
for each sh3 in workbooks("DestBook.xls").Worksheets
sh3.Name = "zxaabir" & i
i = i + 1
Next
sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls")
sh.cells.copy
sh1.Cells.PasteSpecial xlFormats
sh1.Cells.PasteSpecial xlFormulas
sh1.Name = sh.Name
set sh2 = Nothing
On Error Resume Next
set sh2 = sh1.Next
On Error goto 0
if not sh2 is nothing then
set sh1 = sh2
else
set sh1 = worksheets.Add(After:=sh1.Parent.Worksheets( _
sh1.Parent.Worksheets.count))
end if
Next

--
Regards,
Tom Ogilvy

I didn't bench test it, so there is always the chance of an oversight such
as you pointed out.

The best approach would be not to add the sheet not needed. See adjusted
code

Using color or colorindex is usually a matter of personal choice. If it
works, that should be sufficient.

Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim lTotalSheetsDest As Long
Dim sSourceBook As String
Dim sDestBook As String

sSourceBook = "Source.xls"
sDestBook = "Dest.xls"

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)
lCounter = 0
For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
lCounter = lCounter + 1
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color '\New Line

If lCounter < Workbooks(sDestBook).Worksheets.count then
Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 = Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If
End If
Next wksSheet2

End Sub

Your approach to get the last worksheet is the way to do it:
'\New Line Below
Workbooks(sDestBook).Worksheets(Workbooks(sDestBoo k).Worksheets.Count).Delet
e

You can make it more compact using with (also suppress prompt )

With Workbooks(sDestBook)
Application.Displayalerts = False
.Worksheets(.Worksheets.count).Delete
Application.DisplayAlerts = True
End With

--
Regards,
Tom Ogilvy

"Kevin H. Stecyk" wrote in message
...
Hi Tom,

Your subroutine worked wonderfully. As I single stepped through it, I
found
two small oversights.

sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls")

shold be changed to...

Set sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls").Worksheets

Once I installed this subrountine, I discovered these very quickly and
easily. I am mentioning it here for others that might borrow your same
routine.

I have modified your code with my normal syntax and have shown it below.

I have two additional questions:

(1) Did I use the correct code/syntax for assigning tab color? It seems
to
work, and thus I think it is okay. But I am not sure about "color" versus
"colorindex". I have indicated that this is a '\New Line. So it should
be
easy to spot.

(2) The subrountine adds an additional and unnecessary sheet to the
destination workbook. My last line prior to the end of the subrountine
removes a sheet. Did I use the best method? Is there an easier or more
direct method? As I suspect the last sheet should likely have the largest
sheet number, is there a way to select the "max sheet" or is the method
shown perfectly acceptable?

Thank you so much for all your help.

Best regards,
Kevin

Shown below is the modified subrountine. It copies the formulas and
formats
from all the sheets in SourceBook to DestBook. We are having difficulty
(corruption) with the SourceBook and thus want its contents transferred. I
recognize that copying the "formats" potentially infects the
DestinationBook.



Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim lTotalSheetsDest As Long
Dim sSourceBook As String
Dim sDestBook As String

sSourceBook = "Source.xls"
sDestBook = "Dest.xls"

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)

For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color '\New Line

Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 =
Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If

Next wksSheet2

'\New Line Below

Workbooks(sDestBook).Worksheets(Workbooks(sDestBoo k).Worksheets.Count).Delet
e

End Sub


"Tom Ogilvy" wrote in message
...

Dim sh as Worksheet, sh1 as Worksheet, Sh2 as Worksheet
Dim sh3 as Worksheet
Dim i as Long
i = 100
' rename destination sheets with dummy names to
' avoid duplicate sheet name problems
for each sh3 in workbooks("DestBook.xls").Worksheets
sh3.Name = "zxaabir" & i
i = i + 1
Next
sh1 = Workbooks("DestBook.xls").Worksheets(1)
for each sh in workbooks("SourceBook.xls")
sh.cells.copy
sh1.Cells.PasteSpecial xlFormats
sh1.Cells.PasteSpecial xlFormulas
sh1.Name = sh.Name
set sh2 = Nothing
On Error Resume Next
set sh2 = sh1.Next
On Error goto 0
if not sh2 is nothing then
set sh1 = sh2
else
set sh1 = worksheets.Add(After:=sh1.Parent.Worksheets( _
sh1.Parent.Worksheets.count))
end if
Next

--
Regards,
Tom Ogilvy

Hi Tom,

Thank you very much for all your help! I greatly appreciate you providing
the code. Not only did I get the answer that I needed, but I also got an
opportunity to increase my learning. I don't use VBA frequently enough to
always be conversant with it. But with you doing all the heavy lifting, I
was able to get my answer and increase my learning.

There were two small oversights that have been corrected. One was I reset
lCounter=0 and I switched books. The code is documented below. I also
added two small changes. One, I selected "A1" after the formulas and
formats were copied. Two, after the routine is finished I select the first
sheet.

Again, thank you very much for all your help!

Best regards,
Kevin


The routine below copies the formulas and formats from all the sheets in the
"Source" book to the "Destination" book. For those wanting to copy the
code, be careful of the line wrap.



Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim sSourceBook As String
Dim sDestBook As String


sSourceBook = "Source.xls" '\***You need to change this line***
sDestBook = "Destination.xls" '\***You need to change this line***

Application.ScreenUpdating = False

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)

lCounter = 0 '\New line

For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
lCounter = lCounter + 1
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Cells(1, 1).Select '\New Line
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color

If lCounter < Workbooks(sSourceBook).Worksheets.Count Then '\Switched
books
Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 =
Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If
End If
Next wksSheet2

Workbooks(sDestBook).Worksheets(1).Activate '\New Line

Application.ScreenUpdating = True

End Sub


Tom Ogilvy wrote...

I didn't bench test it, so there is always the chance of an oversight such
as you pointed out.

The best approach would be not to add the sheet not needed. See adjusted
code

Using color or colorindex is usually a matter of personal choice. If it
works, that should be sufficient.

Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim lTotalSheetsDest As Long
Dim sSourceBook As String
Dim sDestBook As String

sSourceBook = "Source.xls"
sDestBook = "Dest.xls"

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)
lCounter = 0
For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
lCounter = lCounter + 1
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color '\New Line

If lCounter < Workbooks(sDestBook).Worksheets.count then
Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 =
Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If
End If
Next wksSheet2

End Sub

Your approach to get the last worksheet is the way to do it:
'\New Line Below
Workbooks(sDestBook).Worksheets(Workbooks(sDestBoo k).Worksheets.Count).Delet
e

You can make it more compact using with (also suppress prompt )

With Workbooks(sDestBook)
Application.Displayalerts = False
.Worksheets(.Worksheets.count).Delete
Application.DisplayAlerts = True
End With

--
Regards,
Tom Ogilvy

I think I did reset lCounter:

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)
lCounter = 0
For Each wksSheet2 In Workbooks(sSourceBook).Worksheets

guess you missed it.

But you are correct that the worksheets count should be compared to the
source workbook.

--
Regards,
Tom Ogilvy


"Kevin H. Stecyk" wrote in message
...
Hi Tom,

Thank you very much for all your help! I greatly appreciate you providing
the code. Not only did I get the answer that I needed, but I also got an
opportunity to increase my learning. I don't use VBA frequently enough to
always be conversant with it. But with you doing all the heavy lifting, I
was able to get my answer and increase my learning.

There were two small oversights that have been corrected. One was I reset
lCounter=0 and I switched books. The code is documented below. I also
added two small changes. One, I selected "A1" after the formulas and
formats were copied. Two, after the routine is finished I select the
first
sheet.

Again, thank you very much for all your help!

Best regards,
Kevin


The routine below copies the formulas and formats from all the sheets in
the
"Source" book to the "Destination" book. For those wanting to copy the
code, be careful of the line wrap.



Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim sSourceBook As String
Dim sDestBook As String


sSourceBook = "Source.xls" '\***You need to change this line***
sDestBook = "Destination.xls" '\***You need to change this line***

Application.ScreenUpdating = False

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)

lCounter = 0 '\New line

For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
lCounter = lCounter + 1
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Cells(1, 1).Select '\New Line
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color

If lCounter < Workbooks(sSourceBook).Worksheets.Count Then '\Switched
books
Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 =
Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If
End If
Next wksSheet2

Workbooks(sDestBook).Worksheets(1).Activate '\New Line

Application.ScreenUpdating = True

End Sub


Tom Ogilvy wrote...

I didn't bench test it, so there is always the chance of an oversight
such
as you pointed out.

The best approach would be not to add the sheet not needed. See
adjusted
code

Using color or colorindex is usually a matter of personal choice. If it
works, that should be sufficient.

Sub CopyFormulasFormats()

Dim wksSheet1 As Worksheet '\Destination workbook sheet
Dim wksSheet2 As Worksheet '\Source workbook sheet
Dim wksSheet3 As Worksheet '\Temp source workbook sheet
Dim wksSheet4 As Worksheet '\Destination Sheets for renaming
Dim lCounter As Long
Dim lTotalSheetsDest As Long
Dim sSourceBook As String
Dim sDestBook As String

sSourceBook = "Source.xls"
sDestBook = "Dest.xls"

lCounter = 100
'\rename destination sheets with dummy names to
'\avoid duplicate sheet name problems
For Each wksSheet4 In Workbooks(sDestBook).Worksheets
wksSheet4.Name = "zxaabir" & lCounter
lCounter = lCounter + 1
Next wksSheet4

Set wksSheet1 = Workbooks(sDestBook).Worksheets(1)
lCounter = 0
For Each wksSheet2 In Workbooks(sSourceBook).Worksheets
lCounter = lCounter + 1
wksSheet2.Cells.Copy
wksSheet1.Cells.PasteSpecial xlFormats
wksSheet1.Cells.PasteSpecial xlFormulas
wksSheet1.Name = wksSheet2.Name
wksSheet1.Tab.Color = wksSheet2.Tab.Color '\New Line

If lCounter < Workbooks(sDestBook).Worksheets.count then
Set wksSheet3 = Nothing
On Error Resume Next
Set wksSheet3 = wksSheet1.Next
On Error GoTo 0

If Not wksSheet3 Is Nothing Then
Set wksSheet1 = wksSheet3
Else
Set wksSheet1 =
Worksheets.Add(After:=wksSheet1.Parent.Worksheets( _
wksSheet1.Parent.Worksheets.Count))
End If
End If
Next wksSheet2

End Sub

Your approach to get the last worksheet is the way to do it:
'\New Line Below

Workbooks(sDestBook).Worksheets(Workbooks(sDestBoo k).Worksheets.Count).Delet
e

You can make it more compact using with (also suppress prompt )

With Workbooks(sDestBook)
Application.Displayalerts = False
.Worksheets(.Worksheets.count).Delete
Application.DisplayAlerts = True
End With

--
Regards,
Tom Ogilvy