Solved: Create folders and filename

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:

[vba]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[/vba]

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 [vba]Range("H5").Text & "-huset"[/vba] instead of "H5" in the above code.

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

Found some SL?.OP (LOOKUP in danish) code and placed it in cell H4.

Code:

---

=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?

Something like
[VBA]
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

[/VBA]

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

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.

You could add a simple userform called by Workbook_Open requesting the data for these cells if they are empty.

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:
Attachment 8643

This code seemes to be the reason:
[VBA]
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[/VBA]

What is wrong?

Try
[VBA]
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

[/VBA]

OK, that works. Had to un-merge some cells firt though.
Now, i think, i only need something like
[VBA]If .Range("D2") = "01.01.2000" Or .Range("D2") = "" Or .Range("A4") = "Beboernavn" Or .Range("A4") = "" Then
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")[/VBA]
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?

[vba]
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

[/vba]

I changed it to this:
[vba]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[/vba]
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

Ups, forgot to marked it solved.
Doing it now.