VBA Tabellenblatt in txt und xlsx automatisch speichern

Question

Hallo Zusammen

ich hoffe ihr könnte mir helfen. Ich würde gerne ein Tabellenblatt "Angebot" mit makros automatisch als eine txt Datei abspeichern lassen. Zusätzlich sollte die text Datei ein spezielles format habe. Bis hierhin passt klappt alles.

Nun mein Problem: Wie muss ich mein Code ändern, so dass jedes mal wenn ich die Makros ausführe, ein Fenster aufpoppt damit ich selbst bestimmen kann wie der Datei Name sein soll die gerade abgespeichert wird. Mein Code sieht bis jetzt wie folgt aus:

Sub ascii_datei_exportieren()

Close #1

'Öffnen der Textdatei

Open "G:\03_Ordner\04_Meine_Daten\01_Gruppen\text.txt" For Output As 1

'Schleife für Zeilen

For zeile = 1 To 1000000

If Cells(zeile, 1) = "" Then Exit For

Text = "" 

    'Schleife für Süalten 

    For spalte = 1 To 5 

        Text = Text & CVar(Cells(zeile, spalte)) 

    If spalte < 5 Then Text = Text & "|" 'Trennzeichen = | 

    Next 

Print #1, Text 

Next

'Schließen der Textdatei

Close #1

End Sub

Außerdem hätte ich eine weitere Frage:

Wie müsste mein Code aussehen wenn ich zusätzlich möchte dass das Tabellenblatt nicht nur als txt sondern auch als xslx abgespeichert wird. Aber auf unterschiedliche Orte.

Answer 1

Der Code mit der fortlaufenden Nummer funktioniert in Kombination mit Deinem so nicht... weil der FullPath enthält auch die Dateiendung, Entschuldigung.

Der Code unten macht einen neuen Namen wie der Windows-Explorer.

Andreas.

Function NewFileName(ByVal FullName As String) As String
'Return a filename that did not exists but begins with fullname
' i.E.: c:\temp\test.xla => c:\temp\test(1).xla
Dim i As Long, LeftParen As Long, RightParen As Long, DotPos As Long
Dim LeftPart As String, RightPart As String
If Dir$(FullName) <> "" Then
LeftParen = InStrRev(FullName, "(")
RightParen = InStrRev(FullName, ")")
On Error GoTo AddParen
i = Mid$(FullName, LeftParen + 1, RightParen - LeftParen - 1)
LeftPart = Left$(FullName, LeftParen)
RightPart = Mid$(FullName, RightParen)
GoTo Doit
AddParen:
DotPos = InStrRev(FullName, ".")
If DotPos = 0 Then
LeftPart = FullName & "("
RightPart = ")"
Else
LeftPart = Left$(FullName, DotPos - 1) & "("
RightPart = ")" & Mid$(FullName, DotPos)
End If
Doit:
Do
i = i + 1
NewFileName = LeftPart & i & RightPart
Loop Until Dir$(NewFileName) = ""
Else
NewFileName = FullName
End If
End Function

Answer 2

Also, wenn Du ein AddIn öffnest und es nicht funktioniert, dann wird die Ausführung des Codes von Deinem System unterdrückt. Wahrscheinlich ist die Datei einfach geblockt.

Unblock File in Windows 10 | Tutorials

Oder Du hast die Datei an einem Ort der nicht durch Deine Sicherheitseinstellungen abgedeckt ist. Oder diese unterbinden die Ausführung generell ....

Wie auch immer, Du kann Deinen Code verwenden, aber das gibt früher oder später Murks.
Schau Dir meinen (im AddIn) an, es gehört schon etwas mehr dazu.

Und wie man ein Blatt separiert und als XLSX abspeichert hatte ich schon gezeigt:

'Kopie des Blattes als neue Datei

  ActiveSheet.Copy

  'Fehler aus

  Application.DisplayAlerts = False

  'Abspeichern

  ActiveWorkbook.SaveAs "Z:\test.xlsx", xlOpenXMLWorkbook

  'Fehler an

  Application.DisplayAlerts = True

Und eine automatische "Weiternummerierung" ... klar kann man alles machen, häng einfach eine fortlaufende Nummer an den Dateinamen an und kuck ob er existiert.

Dim i As Long
If Dir(Fullpath) <> "" Then
i = 1
Do While Dir(Fullpath & i) <> ""
i = i + 1
Loop
Fullpath = Fullpath & i
End If

Andreas.

Answer 3

Hallo Andreas,

vielen Dank für deine schnelle Antwort.

hat leider nicht geklappt.

wenn ich deine Datei öffne und dann meine und anschließend mit rechts auf eine Zelle klicke, kommt die CSV option garnicht.

Für die Text Datei habe ich tatsächlich schon ein Code geschrieben die ich anwenden kann.

Sub ascii_datei_exportieren()

Close #1

'Benutzer wählt Pfad und Name aus

Dim Fullpath As Variant

Fullpath = Application.GetSaveAsFilename(FileFilter:="Text-Dateien (*.txt),*.txt")

'Öffnen der Textdatei

Open Fullpath For Output As 1

'Schleife für Zeilen

For zeile = 1 To 1000000

If Cells(zeile, 1) = "" Then Exit For

Text = "" 

    'Schleife für Spalten 

    For spalte = 1 To 5 

        Text = Text & CVar(Cells(zeile, spalte)) 

    If spalte < 5 Then Text = Text & "|" 'Trennzeichen = | 

    Next 

Print #1, Text 

Next

Close #1

'Schließen der Textdatei

End Sub

Mir fehlt jetzt nur noch ein separaten Code für die Speicherung des Tabellenblattes als Excel auf ein bestimmten Pfad aber wo ich den Namen der Datei immer Manuell eingebe. Noch besser wäre es wenn die Datei erkennen würde das es schon Dateien Namen "1, 2, 3" im Ordner drin sind und sich selbst dann mit der nächsten zahl einspeichern würde.

Meinst du dies wäre möglich?

Answer 4

Lad Dir mal das AddIn runter.

https://www.dropbox.com/s/m7qdh5gs3wqb99r/CSV.xla?dl=1

Speicher es irgendwo ab und öffne es.

Dann öffnest Du Deine Datei.

Klick mit Rechts auf eine Zelle, das CSV Menü ist ganz unten, in den Optionen stellst Du das Format ein.

Jetzt gehst Du in den VBA Editor

Extras \ Verweise und da setzt Du einen Haken bei "AddIn_CSV":

In ein reguläres Modul diesen Code

Sub Test()
Dim FName As String
With Application.FileDialog(msoFileDialogSaveAs)
.FilterIndex = 12
.InitialFileName = Environ$("UserProfile") & "\Documents\Mein Dateiname.txt"
.ButtonName = "Abspeichern"
If Not .Show Then Exit Sub
FName = .SelectedItems(1)
End With
CSVExport FName, Intersect(Range("A1").CurrentRegion, Range("A:E"))
End Sub

Wenn das läuft, dann kopierst Du das ganze und rufst statt CSVExport den Part auf:

'Kopie des Blattes als neue Datei
ActiveSheet.Copy
'Fehler aus
Application.DisplayAlerts = False
'Abspeichern
ActiveWorkbook.SaveAs "Z:\test.xlsx", xlOpenXMLWorkbook
'Fehler an
Application.DisplayAlerts = True

Der FilterIndex = 1 ist für xlsx Dateien.

Andreas.