[Løst] Excel, makro som lagrer i mappe på personlig område.

[perroga]

Har laget en .xlsm fil som er blitt så brukbar at den sannsynlig skal deles med mange brukere på jobben.

 

Brukere kan som regel for lite om filstruktur, og i en travel hverdag kan det lett lagres på feil sted.

 

For å sikre at den ikke blir lagret på et fellesområde, vil jeg prøve å finne en programmering som sikrer at den alltid lagres i en bestemt mappe på brukerens personlige område. (Fordi den skal inneholde personnr.)

 

Personlig område: H:\

Mappe: H:\personalskjema\

 

Hvis mappen ikke finnes, ønsker jeg en VBA-kode som lager mappen.

 

og lagrer filen i mappen.

 

Filens navn varierer.

 

Hvis Filnavn finnes fra før i mappen, ønsker jeg at at filen lagres uten spørsmål på det samme navnet.

 

Jeg har søkt mye på nettet men ikke funnet løsning.

 

Håper at noen vil bistå.

Jeg jobber i helsesektoren i en kommune, og dette vil figjøre verdifull arbeidstid for fagpersoner, som idag sløser bort tid med tungvindt tekstbehandling.

 

Med hilsen

 

Per ....

Endret 8. februar 2012 av perroga

[Harald Staff]

Hei Per

 

Denne skal ligge i modulen ThisWorkbook:

 

 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Dim Fil As Variant

Dim Navn As String

Dim Mappe As String

Mappe = "H:\personalskjema"

If SaveAsUI = True Then

Cancel = True

If Dir(Mappe, vbDirectory) = "" Then

On Error Resume Next

MkDir Mappe

End If

On Error GoTo 0

Fil = Application.GetSaveAsFilename(Mappe & "\" & ThisWorkbook.Name, fileFilter:="Exceldokument (*.xlsm), *.xlsm")

If Fil = False Then Exit Sub

If InStr(Fil, Mappe) > 0 Then

Application.DisplayAlerts = False

ThisWorkbook.SaveAs Fil, 52

Application.DisplayAlerts = True

Else

Select Case MsgBox("Dokumentet skal ligge i " & Mappe & ". Skal vi legge den der?", vbOKCancel + vbQuestion)

Case vbOK

Navn = Mid(Fil, InStrRev(Fil, "\"))

Application.DisplayAlerts = False

ThisWorkbook.SaveAs Mappe & Navn, 52

Application.DisplayAlerts = True

Case Else

End Select

End If

End If

End Sub

 

HTH. Beste hilsen Harald

[perroga]

Hei Per

 

Denne skal ligge i modulen ThisWorkbook:

 

 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Dim Fil As Variant

Dim Navn As String

Dim Mappe As String

Mappe = "H:\personalskjema"

If SaveAsUI = True Then

Cancel = True

If Dir(Mappe, vbDirectory) = "" Then

On Error Resume Next

MkDir Mappe

End If

On Error GoTo 0

Fil = Application.GetSaveAsFilename(Mappe & "\" & ThisWorkbook.Name, fileFilter:="Exceldokument (*.xlsm), *.xlsm")

If Fil = False Then Exit Sub

If InStr(Fil, Mappe) > 0 Then

Application.DisplayAlerts = False

ThisWorkbook.SaveAs Fil, 52

Application.DisplayAlerts = True

Else

Select Case MsgBox("Dokumentet skal ligge i " & Mappe & ". Skal vi legge den der?", vbOKCancel + vbQuestion)

Case vbOK

Navn = Mid(Fil, InStrRev(Fil, "\"))

Application.DisplayAlerts = False

ThisWorkbook.SaveAs Mappe & Navn, 52

Application.DisplayAlerts = True

Case Else

End Select

End If

End If

End Sub

 

HTH. Beste hilsen Harald

 

 

Tusen takk! Nå berget du meg.

 

Kopierte den rett inn.

 

Har testet det, og det fungerer helt topp.

[Harald Staff]

Fine greier. Takk for tilbakemelding.

 

Beste hilsen Harald