Problem of "copying worksheets from multiple workbook into a single worksheet"

[thompsonf]

I have written a macro trying to copy worksheets("Upload") from
multiple workbooks to a single Worksheets("MasterUpload") in a Master
Workbooks("MasterUpload.XLS"). During the While loop, the desired
copying range will be appended to the MasterUpload sheet one by one.
However, I have encountered problems in the stability of the macro as
some of the workbooks content doesn't seem to have pasted into the
MasterUpload.

Does anyone have a more stable method of copying and appending into a
single workbook? Cheers.



*********************
Sub BuildMasterUpload()
Dim i, X, Y, iRow, Col, Mrow As Integer
Dim A(1 To 26) As String


Application.ScreenUpdating = False

'/Please this A to Z file name accordingly before running this
Macro
A(1) = "Plan1.xls"
A(2) = "Active1.xls"
A(3) = "Deactive1.xls"
A(4) = "Brilliant.xls"
A(5) = "Central.xls"
A(6) = "London.xls"
A(7) = "Paris.xls"
A(8) = "New York.xls"
A(9) = "Milan.xls"
A(10) = "Tokyo.xls"


Workbooks("MasterUpload.XLS").Activate
Cells.Select
Selection.ClearContents
Range("A1").Select

Workbooks(A(1)).Activate
Application.CutCopyMode = True
Workbooks(A(1)).Worksheets("Upload").UsedRange.Copy
Workbooks("MasterUpload.XLS").Activate
Range("A65536").Select
Selection.End(xlUp).Select
Workbooks("MasterUpload.XLS").Worksheets("MasterUpload").Cells(1,
1).PasteSpecial Paste:=xlValues
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Workbooks(A(1)).Close SaveChanges:=False


i = 2
While Len(A(i)) > 0
On Error Resume Next
Workbooks(A(i)).Activate
Worksheets("Upload").Range("A1").Select
If Err.Number > 0 Then
Else
Application.CutCopyMode = True
iRow = Cells(65536, 1).End(xlUp).Row
Workbooks(A(i)).Worksheets("Upload").Range(Cells(2, 1),
Cells(iRow, 24)).Select
Selection.Copy
Workbooks("MasterUpload.XLS").Activate
Mrow = Cells(65536, 1).End(xlUp).Row
Workbooks("MasterUpload.XLS").Worksheets("MasterUpload").Cells(Mrow
+ 1, 1).PasteSpecial Paste:=xlValues
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Workbooks(A(i)).Close SaveChanges:=False
End If
iRow = 0
i = i + 1
Wend
End Sub

******************************

 

[Dave Peterson]

I didn't set up a test environment, but I did see lots of .selects in your code.

And it might help to find problems if you added some notifications when
something bad happened:

Option Explicit

Sub BuildMasterUpload()

Application.ScreenUpdating = False

Dim iCtr As Long
Dim A(1 To 26) As String
Dim testWkbk As Workbook
Dim testWks As Worksheet

Dim DestCell As Range

'/Please this A to Z file name accordingly before running this Macro
A(1) = "Plan1.xls"
A(2) = "Active1.xls"
A(3) = "Deactive1.xls"
A(4) = "Brilliant.xls"
A(5) = "Central.xls"
A(6) = "London.xls"
A(7) = "Paris.xls"
A(8) = "New York.xls"
A(9) = "Milan.xls"
A(10) = "Tokyo.xls"

Set DestCell = Workbooks("MasterUpload.XLS") _
.Worksheets("whatgoeshere").Range("a1")

DestCell.Parent.Cells.ClearContents

For iCtr = LBound(A) To UBound(A)

If Len(A(iCtr)) = 0 Then
Exit For 'we're done
End If

Set testWkbk = Nothing
On Error Resume Next
Set testWkbk = Workbooks(A(iCtr))
On Error GoTo 0
If testWkbk Is Nothing Then
MsgBox A(iCtr) & " isn't open"
Else
Set testWks = Nothing
On Error Resume Next
Set testWks = testWkbk.Worksheets("upload")
On Error GoTo 0

If testWks Is Nothing Then
MsgBox A(iCtr) & " didn't have an Upload worksheet"
Else
testWks.UsedRange.Copy
DestCell.PasteSpecial Paste:=xlPasteValues
'get ready for the next one
With DestCell.Parent
Set DestCell _
= .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Application.CutCopyMode = False
End If
testWkbk.Close savechanges:=False
End If
Next iCtr

End Sub

Your code depended on values in column A. If you're missing data in that
column, it may throw off the .end(xlup) stuff.