Reputation: 2347
What I want to do
My company uses a tool that needs to be fed with Excel files. These excel files are all based on the same template - which I conveniently named CustomTemplate.xls .
I created a macro which looks at a long list of suppliers and parts, and determines which of them are not in our system. I now want to have a macro that automates as much as possible the process by which templates are created.
We have around 20 different suppliers. Each supplier must have its own template (file), and the parts it supplies will be in that file. Therefore, I need to:
1 - Verify that CustomTemplate_SupplierA.xls exists or is opened already. If not, create a copy from Customtemplate.xls and name it that way.
2 - Fill that template in with my info
What I have
I looked at this: Detect whether Excel workbook is already open And this: Copying and renaming unopened workbook in excel
It led me to create this:
Sub templateFiller(FirstDate As Variant, FinalDate As Variant, LigneExtract As Integer)
Debug.Print "template to be filled with: " & FirstDate & " " & FinalDate & " info on row " & LigneExtract
Dim wbk As Workbook
Dim TemplatePath As String
Dim wbPath As String
Dim supplier As String
Dim lastline As Integer
'Setting the appropriate names:
TemplatePath = "O:\08_Lean_Eng\10_On_going\David\Soldier's Pond\MDR\Templates\TemplateCustom.xls"
supplier = SupDocs.Range("BM" & LigneExtract).Value
wbPath = Mid(TemplatePath, 1, Len(TemplatePath) - 4) & "_" & supplier & ".xls"
'Verifying that the workbook is opened:
If IsWorkBookOpen(wbPath) = False Then
FileCopy TemplatePath, wbPath
End If
Set wbk = Workbooks.Open(wbPath)
'Goes to last line and fills in my info
lastline = wbk.Sheets("DL001").Range("A").End(xlUp).Row
wbk.Sheets("Dl001").Range("A" & lastline) = LigneExtract
End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Which resulted in an error at the Case Else in the function. I assumed this meant the workbook did not exist and the function only worked when the workbook existed, so I went to this site http://www.ozgrid.com/VBA/IsWorkbookOpen.htm and used a slightly DoesWorkBookExist function like so:
Function DoesWorkBookExist(wbpath) As Boolean
Dim i As Integer
With Application.FileSearch
.LookIn = "O:\08_Lean_Eng\10_On_going\David\Soldier's Pond\MDR\Templates"
.FileName = Mid(wbpath, 63)
If .Execute > 0 Then 'Workbook exists
DoesWorkBookExist = True
Else 'There is NOt a Workbook
DoesWorkBookExist = False
End If
End With
End Function
Calling it from the sub instead of the previous function. I get an error on Appliction.FileSearch:
"This object does not support that function" (translated like I could)
Are any of these two functions needed for what I am doing? Is there a simpler way, or am i doing something wrong which causes these errors?
EDIT: Final code (works like a charm)
Sub templateFiller(FirstDate As Variant, FinalDate As Variant, LigneExtract As Integer)
Debug.Print "template to be filled with: " & FirstDate & " " & FinalDate & " info on row " & LigneExtract
Debug.Print "supplier's name: " & SupDocs.Range("BM" & LigneExtract).Value
Dim wbk As Workbook
Dim TemplatePath As String
Dim wbpath As String
Dim supplier As String
Dim lastline As Integer
Dim wbname As String
TemplatePath = "O:\08_Lean_Eng\10_On_going\David\Soldier's Pond\MDR\Templates\TemplateCustom.xls"
supplier = SupDocs.Range("BM" & LigneExtract).Value
wbpath = Mid(TemplatePath, 1, Len(TemplatePath) - 4) & "_" & supplier & ".xls"
wbname = Mid(wbpath, 63)
'Vérifie que le workbook a remplir est ouvert
'Ouvre si non
If Dir(wbpath) <> "" Then
If IsWorkBookOpen(wbpath) = False Then
FileCopy TemplatePath, wbpath
End If
Else
MsgBox wbpath & " File Not found"
Exit Sub
End If
If IsWorkBookOpen(wbpath) = False Then
Set wbk = Workbooks.Open(wbpath)
Else
Set wbk = Workbooks(wbname)
End If
'Va à la dernière ligne vide
'Inscrit infos
lastline = wbk.Sheets("DL001").Range("A65000").End(xlUp).Row + 1
wbk.Sheets("Dl001").Range("A" & lastline) = LigneExtract
End Sub
Function IsWorkBookOpen(filename As String) As Boolean
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open filename For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Upvotes: 2
Views: 223
Reputation: 149305
Which resulted in an error at the Case Else in the function.
You are getting that error because IsWorkBookOpen
is not able to find the file.
Replace
If IsWorkBookOpen(wbPath) = False Then
FileCopy TemplatePath, wbPath
End If
with
If Dir(wbPath) <> "" Then
If IsWorkBookOpen(wbPath) = False Then
FileCopy TemplatePath, wbPath
End If
Else
MsgBox wbPath & " File Not found"
Exit Sub
End If
And try again.
Tim has already answered in the comment below the question that the Application.FileSearch
which has been discontinued from Excel 2007.
Edit
1 - Verify that CustomTemplate_SupplierA.xls exists or is opened already. If not, create a copy from Customtemplate.xls and name it that way.
2 - Fill that template in with my info
This is how I would do it (untested). I am using hard coded values for demonstration purpose.
Sub Sample()
Dim wbPath As String, TemplatePath As String
Dim wb As Workbook
TemplatePath = "C:\TemplateCustom.xls"
wbPath = "C:\CustomTemplate_SupplierA.xls"
If Dir(wbPath) <> "" Then
'~~> If File is Closed
If IsWorkBookOpen(wbPath) = False Then
FileCopy TemplatePath, wbPath
Set wb = Workbooks.Open(wbPath)
'~~> If File is open
Else
Set wb = Workbooks("CustomTemplate_SupplierA.xls")
End If
With wb.Sheets("Sheet1")
'
'~~> Write Something
'
End With
Else
MsgBox wbPath & " File Not found"
Exit Sub
End If
End Sub
Upvotes: 2