PDA

View Full Version : Solved: Create folders and filename



perhol
05-06-2008, 05:03 AM
I am in the process of making sure that users save account-sheets in right folder and with a filename that identify the sheet correctly.

For that i have used code found in this thread
http://www.vbaexpress.com/forum/showthread.php?t=11572
and just slightly modifyed.

Here is the code in full:

Sub GemSom()
ActiveWorkbook.SaveAs CheckMakePath("G:\" & _
Sheets("Kasserapport").Range("H5").Text & "-huset" & "\" & "Beboere" & "\" & _
Sheets("Kasserapport").Range("D2").Text & "\" & "Regnskab" & "\" & _
Format(Sheets("Kasserapport").Range("A4"), "yyyy")) & _
"Regnskab " & Format(Sheets("Kasserapport").Range("A4"), "mm-yyyy") & _
" " & Sheets("Kasserapport").Range("D2").Text & ".xls"
End Sub

Function CheckMakePath(ByVal vPath As String) As String
Dim PathSep As Long, oPS As Long
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
PathSep = InStr(3, vPath, "\") 'Position af drev-seperatoren i stien
If PathSep = 0 Then Exit Function 'Ugyldig sti
Do
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\") 'Position af folder
If PathSep = 0 Then Exit Do
If Len(Dir(Left(vPath, PathSep), vbDirectory)) = 0 Then Exit Do 'check stien
Loop
Do Until PathSep = 0
MkDir Left(vPath, PathSep)
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\")
Loop
CheckMakePath = vPath
End Function

The code works as expected, except that i need to lookup part of the path and filename, and i need to make sure that at least 2 cells is populatet.

The account-sheet is for occupants in 3 houses Named A-huset, B-huset and C-huset, each with 8 occupants.

The name of the house must bee in the path (e.g. G:\A-huset\Beboere\Lena Frederiksen . . . . . )
The name is taken from a list in column I rows 5 to 28 and filled in cell D2. In column H is the A-, B- or C-part of the house name. That should be looked up and used in the Range("H5").Text & "-huset" instead of "H5" in the above code.

Also, how do i make sure that cells D2 and A4 is populated before save?

perhol
05-06-2008, 09:34 AM
Found some SL?.OP (LOOKUP in danish) code and placed it in cell H4.

=SL?.OP(D2;I5:I28;H5:H28)
So, now I only need to make sure that cells D2 and A4 is populated before save.

How do i do that?

mdmackillop
05-06-2008, 10:35 AM
Something like

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
With Sheets(1)
If .Range("D2") = "" Or .Range("A4") = "" Then
Cancel = True
MsgBox "Not Saved" & vbCr & "Please complete cells D2 and A4"
End If
End With
End Sub

perhol
05-06-2008, 12:07 PM
It works.
Could a code like that be inserted in the Sub GemSom() to ensure that the sub does not run when D2 or A4 is not populated?

The file is a template. Is it possible to open a messagebox, telling user to populate D2 and A4, but only on creating a new file from the template?

Actually, my initial question is solved. Should i make a new thread for theese 2 questions? :confused3

perhol
05-06-2008, 12:15 PM
OK, just found a new problem :confused:
I need to save the template without D2 and A4 populated, and that can not be done with the Workbook_BeforeSave sub.
Or could i clear D2 and A4 on creating a new file from the template.

mdmackillop
05-06-2008, 12:19 PM
You could add a simple userform called by Workbook_Open requesting the data for these cells if they are empty.

perhol
05-06-2008, 01:56 PM
I have put some code in an existing Workbook_Open.

On opening the file, either as a template or as *.xls i recieve this error:
8643

This code seemes to be the reason:

Private Sub Workbook_Open()
AddIns("Analysis ToolPak").Installed = True
AddIns("Analysis ToolPak - VBA").Installed = True
AddIns("Pop-up Calendar").Installed = True
Call OpretMenu
Sheets(Kasserapport).Select
If .Range("D2") = "01.01.2000" Or .Range("A4") = "Beboernavn" Then
Range("D2").Select
Selection.ClearContents
Range("A4").Select
Selection.ClearContents Range("D2").Select
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")
End If
End Sub

What is wrong?

mdmackillop
05-06-2008, 02:00 PM
Try

Private Sub Workbook_Open()
AddIns("Analysis ToolPak").Installed = True
AddIns("Analysis ToolPak - VBA").Installed = True
AddIns("Pop-up Calendar").Installed = True
Call OpretMenu
With Sheets("Kasserapport")
.Activate
If .Range("D2") = "01.01.2000" Or .Range("A4") = "Beboernavn" Then
.Range("D2").ClearContents
.Range("A4").ClearContents
.Range("D2").Select
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")
End If
End With
End Sub

perhol
05-06-2008, 02:45 PM
OK, that works. Had to un-merge some cells firt though.
Now, i think, i only need something like
If .Range("D2") = "01.01.2000" Or .Range("D2") = "" Or .Range("A4") = "Beboernavn" Or .Range("A4") = "" Then
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")
in the Sub GemSom() (shown first in the thread) to ensure that the sub does not run when D2 or A4 is not populated.
Can you help me with this also?

mdmackillop
05-06-2008, 03:18 PM
Sub GemSom()
Dim ws As Worksheet
Set ws = Sheets("Kasserapport")
If Test(ws) = True Then
With Sheets("Kasserapport")
ActiveWorkbook.SaveAs CheckMakePath("G:\" & .Range("H5").Text & "-huset" & "\" & "Beboere" & "\" & _
.Range("D2").Text & "\" & "Regnskab" & "\" & _
Format(.Range("A4"), "yyyy") & _
"Regnskab " & Format(.Range("A4"), "mm-yyyy") & _
" " & .Range("D2").Text & ".xls")
End With
Else
MsgBox "Please fill fields"
End If
End Sub

Function Test(ws As Worksheet) As Boolean
If ws.Range("A4") <> "" And ws.Range("D2") <> "" Then Test = True
End Function

Function CheckMakePath(ByVal vPath As String) As String
Dim PathSep As Long, oPS As Long
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
PathSep = InStr(3, vPath, "\") 'Position af drev-seperatoren i stien
If PathSep = 0 Then Exit Function 'Ugyldig sti
Do
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\") 'Position af folder
If PathSep = 0 Then Exit Do
If Len(Dir(Left(vPath, PathSep), vbDirectory)) = 0 Then Exit Do 'check stien
Loop
Do Until PathSep = 0
MkDir Left(vPath, PathSep)
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\")
Loop
CheckMakePath = vPath
End Function

perhol
05-06-2008, 03:56 PM
I changed it to this:
Sub GemSom()
Dim ws As Worksheet
Set ws = Sheets("Kasserapport")
If Test(ws) = False Then
With Sheets("Kasserapport")
ActiveWorkbook.SaveAs CheckMakePath("G:\" & _
Sheets("Kasserapport").Range("H4").Text & "-huset" & "\" & "Beboere" & "\" & _
Sheets("Kasserapport").Range("D2").Text & "\" & "Regnskab" & "\" & _
Format(Sheets("Kasserapport").Range("A4"), "yyyy")) & _
"Regnskab " & Format(Sheets("Kasserapport").Range("A4"), "mm-yyyy") & _
" " & Sheets("Kasserapport").Range("D2").Text & ".xls"
End With
Else
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")
End If
End Sub

Function Test(ws As Worksheet) As Boolean
If ws.Range("A4") = "" Or ws.Range("A4") = "01.01.00" Or ws.Range("D2") = "" Or ws.Range("D2") = "Beboernavn" Then Test = True
End Function
in order to not allow file to be saved with dummy-data in D2 or A4.

Now it works.

Trapping on-close have to wait to another day.

Thank you. Tonight you are my hero :yay

perhol
05-06-2008, 09:00 PM
Ups, forgot to marked it solved.
Doing it now.