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