Speichern der Excel-Arbeitsmappe

[Royalty]

Wir arbeiten mit einer Excel Arbeitsmappe, die auf Dokumente zugreift, die im gleichen Ordner abgelegt sind. Diese Dokumente sind der Ordnunghalber in einem Unterordner zusammen gefasst.

Jetzt möchte ich die Arbeitsmappe mit vor dem schließen mit einem Speicherdialog abspeichern. Dieser Speicherdialog sieht wie folgt aus:

Sub save_close()
Worksheets("Datenbank").Cells(2, 85) = "BiV_ESF" & Worksheets("Datenbank").Cells(2, 1).Value
Application.Dialogs(xlDialogSaveAs).Show Worksheets("Datenbank").Cells(2, 85)

End Sub


Hier wird das Save-Dialogfenster aufgerufen und auch ein Name vorgegeben, der sich aus "Biv_ESF" und der Kundennummer zusammen setzt.

Soweit, so funktionstüchtig.

Allerdings habe ich ein kleines Problem. Diese Datei wird jetzt im Kundenordner abgelegt, wobei hier dann der Unterordner fehlt.

Ist es möglich, den o.g. Code zu erweitern und über den Savedialog den Ordner "automatisch" ins gleiche Verzeichnis zu kopieren, wo die Exceldatei dann gespeichert wird?

In Excel gibt es ja die

Code:

FileSystemObject.CopyFolder

funktion, nur weiß ich jetzt nicht, wie ich den Savedialog bzw. den Dateiort aus dem Savedialog hier einbauen kann.

Gruß
Roy

[BoskoBiati]

Hi,

dann muß der Name des Unterordners in den Text mit rein.

[Royalty]

Leider verstehe ich nicht ganz, wo ich den einsetzen muß.

Der Savediaolog lässt mich ja einen Speicherort für die Excelarbeitsmappe aussuchen und nun soll der Unterordner mit den Namen "Dokumente" auch dort hin kopiert werden.

Verschiedene Ansätze mit thisworkbook.path und copy.folder geben nur Fehler aus.

[BoskoBiati]

Hi

hier&"BiV_ESF"

[Royalty]

Das verstehe ich schon.

Der Code funktioniert auch soweit.

Sub test()

Dim fso As New FileSystemObject
Dim PfadOrdner As String
PfadOrdner = ThisWorkbook.Path & ("\Dokumente")
Debug.Print Dir(PfadOrdner)
'Existiert der Ordner

If fso.FolderExists(PfadOrdner) Then

fso.CopyFolder ThisWorkbook.Path & "\Dokumente", ThisWorkbook.Path & "\Test"

End If
End Sub


Problem ist nun, das ich es nicht hinbekomme, das Zielverzeichnis richtig zu setzen.


Wenn ich also hier also den Pfad wähle

Sub save_close()
Worksheets("Datenbank").Cells(2, 85) = "BiV_ESF" & Worksheets("Datenbank").Cells(2, 1).Value
Application.Dialogs(xlDialogSaveAs).Show Worksheets("Datenbank").Cells(2, 85)

End Sub

soll der ausgewählte Pfad dann gesetzt werden - die Destination von ThisWorkbook.Path & "\Test" auf den Zielpfad geändert werden.

Bin schon am überlegen, ob ich mir den Start und Zielpfad erst in der Tabelle zwischenspeicher??

Gruß
Roy

[d'r Bastler]

Moin Roy,

wozu der Speicher-Dialog? Wenn Du die notwendigen Werte, also Ordner (der muss allerdings unterhalb Deiner Datei vorhanden sein. Das könnte nebenbei der Grund für Deine Fehlermeldungen sein) und Dateiname schon in Deiner Datei hast, geht das mit einem einfachen Makro:

Code:

Option Explicit

Sub Versiv()
Dim wb As Workbook, ws As Worksheet, sPath As String, sFolder As String, sFile As String, sName as String

Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
sPath = wb.Path & "\"

sFolder = "DeinUnterordner" & "\"       'Anpassen!
sFile = "DeineDatei.xlsx"               'Anpassen!
'sFile = Cells(1,1) & ".xlsx"           'Alternativ der Wert einer Zelle
sName = sPath & sFolder & sFile

MsgBox "Diese Datei wird unter " & sName & " gespeichert."
wb.SaveCopyAs (sName)

End Sub

So ist es egal, wo Du Deine Ordnerstruktur hast. Die neue Datei liegt immer unterhalb.

Alternativ noch als Einzeiler ohne Messagebox:

Code:

Sub Version()
ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & Cells(1, 1) & "\" & Cells(1, 2) & ".xlsx"
End Sub

Außer Backslash und Dateiendung steht alles in der Tabelle

Grüße

[Royalty]

Der Speicherdialog muß sein, da einige Kunden noch nicht auf dem Laufwerk vorhanden sind und der Ordner erst angelegt werden muß. Darüber hinaus ist nur die Kundennummer bekannt, der Dateiname variiert nach Einzugsgebiet und daher setzt sich der neue Dateiname aus ESF_BiV und der Kundennummer zusammen. Das nur zur Erklärung. Dazu kommt noch, dass die Kundennummern auf dem Laufwerk in Ordner geliedert werden.
D.h. die Kundennummern in den Ordnern schon nach Kundennummern sortiert werden. Das sieht dann so aus

Ich öffne den Ordner sehe die folgende Ordner
Ordner ESF_BiV530001
Ordner ESF_BiV530051
Ordner ESF_BiV530101

Kick ich dann auf den Ordner ESF_BiV530001 werden folgende Ordner angezeit:
Ordner ESF_BiV530001
Ordner ESF_BiV530002
Ordner ESF_BiV530003
ect bis 50

Der Speicherdialog ist hier die einfachste Variante, den richtigen Ordner anzusteuern, da die Kundennummern nicht druchgehend im gleichen Ordner sind, sonder extra nochmal verteilt sind.

Ich habe also den Kunden 530003 und arbeite mit einer Tabelle, die "nicht" in dem Ordner entsprechend abgelegt ist. Ich beende meine Arbeit und möchte nun die Datei im richtigen Ordner abspeichern, was auch geht. Es fehlt aber dann halt der Ordner, der ja nur im Ursprungsverzeichnis abgelegt ist.
Und hierfür suche ich also eine Lösung. Am besten speichern durch ort auswählen und automatisch den Ordner mit rüber ziehen, damit die Kundendaten dann für den nächsten Bearbeiter dort richtig drin sind.

[BoskoBiati]

Hi,


was denn jetzt, BiV_ESF oder ESF_BiV?

Hier mal eine ungetestete Möglichkeit:

Code:

Sub save_close()
with Worksheets("Datenbank")
select case clng(Right(.cells(2,1)))
  case <51
     StrPfad="ESF_BiV530001/"
  case <101
     StrPfad="ESF_BiV530051/"
  case else
     StrPfad="ESF_BiV530101/"
end select
.Cells(2, 85) = strPfad & "BiV_ESF" & .Cells(2, 1)

Application.Dialogs(xlDialogSaveAs).Show .Cells(2, 85)
end with
End Sub

Im Übrigen halte ich es nicht für witzig einen Ordner so zu benennen wie einen Unterordner.

Ich öffne den Ordner sehe die folgende Ordner
Ordner ESF_BiV530001
Ordner ESF_BiV530051
Ordner ESF_BiV530101

Kick ich dann auf den Ordner ESF_BiV530001 werden folgende Ordner angezeit:
Ordner ESF_BiV530001
Ordner ESF_BiV530002
Ordner ESF_BiV530003

[d'r Bastler]

Moin Roy,

und ich brauche immer noch keinen Dialog ...

Code:

Sub Versiv()
Dim wb As Workbook, sPath As String, sFolder As String, sFile As String

Set wb = ThisWorkbook
sPath = wb.Path

sFolder = "DeinUnterordner"
sFile = "DeineDatei.xlsx"

If Dir(sFolder) = vbNullString Then
    MsgBox "Der Unterordner " & sFolder & " wird neu angelegt!"
    MkDir (sPath & "\" & sFolder)
End If

MsgBox "Diese Datei wird unter " & sPath & "\" & sFolder & "\" & sFile & " gespeichert."

End Sub

p.s. das SaveCopyAs (s.o.) musst Du natürlich noch anfügen.


Grüße

[Royalty]

Hi Boskobati

ich habe den Code mal versucht, wobei ich eine Fehlermeldung in dieser Zeile bekomme:

Code:

select case clng(Right(.cells(2,1)))

Hier wird im Debugmodus das "Right" angezeigt.

Ja, ich stimmt zu, dass es mit der Ordnerverwaltung nicht gut ist. Aber es wird so seit Jahren so gemacht und ändern will man das nicht.

Gruß
Roy