VBA open file and copy tabs

[george hart]

I need to open certain files according to the date within the file name and copy certain tabs: e.g: DyChrt2060711.xls

If I omit dte and the inputbox and just want to get DyChrt2.xls it works fine, but I need the option for one to enter the date to get the right file.

The code below appear to do nothing????

Dim wbOpen As Workbook
Dim wbNew As Workbook
'Change Path
Const strPath As String = "C:\Documents and Settings\HartG\My Documents\Dave Slater\"
Dim strExtension As String
Dte = InputBox("Enter the date")
ChDrive strPath
ChDir strPath
'Change extension
strExtension = Dir("DyChrt2 & dte & .xls")
Dim Tabs As Variant
Tabs = Array("LAIRA STOP", "LANDORE", "SPM", "OOC STOP")
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension, UpdateLinks:=0)
With wbOpen
.Sheets(Tabs).Copy After:=ThisWorkbook.Sheets(1)
.Close SaveChanges:=False
End With

strExtension = Dir
Loop

End Sub

Any help would be most appreciated

 

[Ralajer]

Not sure if this is the only problem but there is a typo on this line

strExtension = Dir("DyChrt2 & dte & .xls")

it should be
strExtension = Dir("DyChrt2" & dte & ".xls")

Although, I don't know why it would work if you omit the date unless you have a file named DyChrt2 & dte & .xls

 

[Jerry Sullivan]

In addition to Rob's comment, the Do Loop isn't necessary if you are only processing one file at a time.

The code in red font below is typically used to process all files meeting a filespec in a folder.

Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension, UpdateLinks:=0)
With wbOpen
     .Sheets(Tabs).Copy After:=ThisWorkbook.Sheets(1)
     .Close SaveChanges:=False
End With 
strExtension = Dir
Loop

 

[Ralajer]

Jerry is correct about the do Loop but you will need an if statement to avoid a runtime error if the file path and name to open doesn't exist. The do loop provides a kind of if statement but it would probably be better to have feedback if the file wasn't found.

If strExtension <> "" Then
     Set wbOpen = Workbooks.Open(strPath & strExtension, UpdateLinks:=0)
     With wbOpen
          .Sheets(Tabs).Copy After:=ThisWorkbook.Sheets(1)
          .Close SaveChanges:=False
     End With 
Else
     MsgBox strPath & StrExtension & vbCr & "Doesn't Exist"
End If

 

[george hart]

Resolved...thanks very much for your help. Most apeciated.

For those that are interested, the code below works a treat...:


Sub GetTabs()
Dim wbOpen As Workbook
Dim wbNew As Workbook
'Change Path
Const strPath As String = "C:\Documents and Settings\HartG\My Documents\Dave Slater\"
Dim strExtension As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'dte = InputBox("Enter the date")
dte = Format$(Range("C1").Value, "ddmmyy")

'Remove existing tabs
Call DelTabs
ChDrive strPath
ChDir strPath
'Change extension
strExtension = Dir("DyChrt2" & dte & ".xls")
Dim Tabs As Variant
Tabs = Array("LAIRA STOP", "LANDORE", "SPM", "OOC STOP")
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension, UpdateLinks:=0)
With wbOpen
.Sheets(Tabs).Copy After:=ThisWorkbook.Sheets(1)
.Close SaveChanges:=False
End With

strExtension = Dir
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Sheets("Data").Select
End Sub