Option Explicit
Sub GetCellsFromWorkbooks()
Dim Mnumb
Dim Aworkbook As Workbook
Dim Aworkbook2 As Workbook
Dim AWorkbook3 As Workbook
Dim sFileBase As String
Dim sFilename As String
Dim Morg
Dim Mto
Dim Sht As Worksheet
Set AWorkbook3 = ActiveWorkbook
Mnumb = 101
Range("A8").Select
For i = 1 To 850
sFileBase = "X:\Users\Shared\GENERAL\Christian S\05.10.28 - " & _
"Budget packs - Capital expenditure - comments\Test\BFR"
& _
Mnumb
sFilename = sFileBase & " bud v2.1.xls"
Set Aworkbook = Workbooks.Open(Filename:=sFilename, UpdateLinks:=0)
If Not SheetExists("Sch 7A", Aworkbook) Then Exit For
Set Aworkbook2 = Workbooks.Add
Aworkbook2.SaveAs Filename:=sfgilebase & " bud v2.1-2.xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Aworkbook2.Activate
ActiveCell = Mnumb
Morg = Lbud.TextBox_org
Mto = Lbud.TextBox_to
On Error Resume Next
For Each Sht In Worksheets
Aworkbook.Sheets("Sch 7A").Range("A1:X250").Select
Selection.Copy
Aworkbook2.Select
Aworkbook2.Sheets.Add
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next
On Error GoTo 0
Aworkbook.Close
Application.CutCopyMode = False
Mnumb = Mnumb + 1
Next i
Errorhandler:
Mnumb = Mnumb + 1
Resume
End Sub
'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
End Function
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Ctech" wrote in
message ...
All the files in the specified folder have the same name except one
number
This part opend the files:
' start number of file name
Mnumb = 101
' When the file doesn't exist
On Error GoTo Errorhandler
For i = 1 To 850
SFilename = "X:\Users\Shared\GENERAL\Christian S\05.10.28 - " & _
"Budget packs - Capital expenditure - comments\Test\BFR" & Mnumb & "
bud v2.1.xls"
Application.Workbooks.Open Filename:=SFilename, UpdateLinks:=0
--
Ctech
------------------------------------------------------------------------
Ctech's Profile:
http://www.excelforum.com/member.php...o&userid=27745
View this thread: http://www.excelforum.com/showthread...hreadid=483865