View Single Post
  #13   Report Post  
Posted to microsoft.public.excel.programming
PatK PatK is offline
external usenet poster
 
Posts: 96
Default Concatentating Multiple Worksheets into One

Sorry...I marked wrong line...see correct erroring line
Sub MergeSheets(result As Boolean) 'result makes macro invisible
Dim basebook As Workbook
Dim mybook As Workbook
Dim N As Long
Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim FirstPage As Boolean

SaveDriveDir = CurDir
MyPath = "C:\Documents and Settings\pklocke\My Documents\4- _
Sourcing\Spreadsheets\Pareto"
ChDrive MyPath
ChDir MyPath

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), _
*.xls", MultiSelect:=True)
If IsArray(FName) Then
Application.ScreenUpdating = False
Set basebook = ActiveWorkbook

For N = LBound(FName) To UBound(FName)
Set mybook = Workbooks.Open(FName(N))
mybook.Worksheets.Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
mybook.Close False
Next
End If
Workbooks("Performance Metrics Template.XLS").Activate

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
MsgBox "Default Subdirectory Changed to: " & SaveDriveDir

FirstPage = False

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "MergeSheet" if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("MergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "MergeSheet"
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "MergeSheet"
Workbooks("Performance Metrics Template.XLS").Activate
Worksheets("Mergesheet").Activate

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets

If sh.Name < DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If Not FirstPage Then 'only copy headers from
first page
sh.Range(sh.Rows(1), sh.Rows(shLast)).Copy DestSh.Cells(Last _

+ 1, "A")
'<<<<<<<<<<<<<< failing now on the above line (object error,

' assuming on sh, but no idea why.

FirstPage = True
Else
sh.Range(sh.Rows(2), sh.Rows(shLast)).Copy DestSh.Cells(Last _

+ 1, "A")
'<<<<<<<<<<<<<< assume it will also fail here, next worksheet.
End If
End If
Next

Application.GoTo DestSh.Cells(1)

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub