Johnny Thunder
Well-known Member
- Joined
- Apr 9, 2010
- Messages
- 693
- Office Version
- 2016
- Platform
- MacOS
Hi guys, have an issue that is giving me a headache.
I have 25 .xls files (formatted for 97-2003 Worksheet). All the files are the same and have the same data in them. The only difference of the files is a few Headers of Territory names (i.e contry names).
I have a macro on a seperate .xlsm file that inserts two new sheets with some data and some formatted Borders. The issue I am having is that about 20 of the .xls files copy over the new sheets without any issues, but I have 5 that copy over the details just fine but the borders are all missing?
Any help on this is appreciated.
My code below
I have 25 .xls files (formatted for 97-2003 Worksheet). All the files are the same and have the same data in them. The only difference of the files is a few Headers of Territory names (i.e contry names).
I have a macro on a seperate .xlsm file that inserts two new sheets with some data and some formatted Borders. The issue I am having is that about 20 of the .xls files copy over the new sheets without any issues, but I have 5 that copy over the details just fine but the borders are all missing?
Any help on this is appreciated.
My code below
Code:
Public Sub CopySheet()
Dim SourceSheet As Worksheet, SourceSheet2 As Worksheet
Dim folder As String, filename As String, vFilename As String, vFileWKBK, vFilepath As String
Dim vCell As Range
Dim DestBook As Workbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
'Worksheet in active workbook to be copied as a new sheet to the 160 workbooks
Set SourceSheet = ThisWorkbook.Worksheets("R&O")
Set SourceSheet2 = ThisWorkbook.Worksheets("Executive Summary")
For Each vCell In Range("LISTTERRITORYNAME").Cells
vFilepath = ThisWorkbook.Path & "\" 'Uses the files folder location for directory
vFileWKBK = Range("TBTPREFIX").Value & " - " & vCell.Value & ".xls*"
vFilename = vFilepath & vFileWKBK
Application.AskToUpdateLinks = False 'Supresses External links warning
If Dir(vFilename) <> "" Then
Set DestBook = Workbooks.Open(vFilename)
SourceSheet.Cells.Copy
On Error Resume Next
Worksheets.Add(After:=Worksheets("Tables")).Name = "R&O"
With DestBook.Sheets("R&O").Range("A1")
.PasteSpecial
ActiveWindow.DisplayGridlines = False
Application.CutCopyMode = False
End With
'-------Print Setup---------
With DestBook.Sheets("R&O").PageSetup
.Zoom = False
.PrintArea = "$A$1:$L$30"
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintGridlines = False
.Orientation = xlLandscape
End With
SourceSheet2.Cells.Copy
Worksheets.Add(After:=Worksheets("Tables")).Name = "Executive Summary"
With DestBook.Sheets("Executive Summary").Range("A1")
.PasteSpecial
.Tab.Color = 255
ActiveWindow.DisplayGridlines = False
Application.CutCopyMode = False
End With
'-------Print Setup---------
With DestBook.Sheets("Executive Summary").PageSetup
.Zoom = False
.PrintArea = "$A$1:$H$62"
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintGridlines = False
.Orientation = xlLandscape
End With
With DestBook
Sheets("R&O").Tab.Color = 255
Sheets("Executive Summary").Tab.Color = 255
End With
On Error GoTo 0
DestBook.Close True
Else
'MsgBox vFileWKBK & " Not Found"
End If
Next vCell
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub