ich habe in einer Arbeitsmappe insgesamt 100 Tabellen, die ich alle getrennt als .txt-Datei abspeichern möchte. Als Dateinamen, soll der Tabellen-Name übernommen werden.
Hat jemand vielleicht eine Idee wie ich das umsetzen kann?
Viele Grüße
Jaylan
Sub Tabellen_als_Text_speichern()
Dim wkb_Q As Workbook, wks_Q As Worksheet, bolOK As Boolean
Set wkb_Q = ActiveWorkbook
Application.ScreenUpdating = False
'Alle Tabellenblatt in der Arbeitsmappe als Text-Datei speichern
For Each wks_Q In wkb_Q.Worksheets
Application.StatusBar = wks_Q.Index & ". Blatt von " _
& wkb_Q.Worksheets.Count & " Wird gespeichert"
bolOK = fncSave_as_Text( _
strPfad:="C:\Users\Public\Test\", _
wks:=wks_Q, _
lngFileFormat:=23, _
bolRename:=True) 'Parameter ggf. anpassen
If Not bolOK Then
MsgBox "Makro wird wegen Fehler abgebrochen", _
vbOKOnly, "Speichern als Text-Datei"
Exit For
End If
Next
Application.ScreenUpdating = True
Application.StatusBar = False
If bolOK Then
MsgBox "Fertig!", vbInformation + vbOKOnly, "Speichern als Text-Datei"
End If
End Sub
Function fncSave_as_Text(strPfad As String, wks As Worksheet, _
lngFileFormat As Long, _
Optional bolRename As Boolean = False, _
Optional bolLocal As Boolean = True) As Boolean
'strPfad = Speicherpfad für Text-Dateien
'wks = Tabelenblatt, das als Text/CSV gespeichert werden soll
'lngFileFormat = Text/CSV-Format in dem das Tabellenblatt gespeichert werden soll
'VBA-Konstane Wert Beschreibung / Trennzeichen
'xlCurrentPlatformText -4158 Current Platform Text / TAB
'xlTextMac 19 Macintosh Text / TAB
'xlTextMSDOS 21 MSDOS Text / TAB
'xlTextPrinter 36 Printer Text / füllende Leerzeichen
'xlTextWindows 20 Windows Text / TAB
'xlUnicodeText 42 Unicode Text / TAB
'Trennzeichen bei CSV-Formaten gemäß Parameter Local
'xlCSV 6 CSV
'xlCSVMac 22 Macintosh CSV
'xlCSVMSDOS 24 MSDOS CSV
'xlCSVWindows 23 Windows CSV
'bolLocal = Legt fest, welche Trennzeichen und Zahlen-/Datumsformate _
in die txt-/csv-Datei geschrieben werden.
'True = gemäß Länder-Einstellungen in Systemsteuerung
'False = gemäß Einstellungen USA
'Trennzeichen = Komma
'Zahlen mit Punkt als Dezimalzeichen
'Datumsformat = M/T/JJJJ
'bolRename = kann bei CSV-Formaten auf True gesetzt werden, wenn die _
Erweiterung des Dateinamens von "csv" in "txt" geändert werden soll
Dim wkb_Txt As Workbook
Dim strExt As String
On Error GoTo Fehler
Select Case lngFileFormat
Case -4158, 18, 20, 21, 36, 42 'Text-Formate
strExt = ".txt"
Case 6, 22, 23, 24 'CSV-Formate
strExt = ".csv"
Case Else
fncSave_as_Text = False
MsgBox "unzulässige Textdatei-Format Nr.: " & lngFileFormat, _
vbOKOnly, "Speichern als Textdatei"
GoTo Fehler
End Select
'Tabellenblatt kopieren in neue Mappe
wks.Copy
Set wkb_Txt = ActiveWorkbook
Application.DisplayAlerts = False
wkb_Txt.SaveAs _
Filename:=strPfad & wks.Name & strExt, _
FileFormat:=lngFileFormat, _
Local:=bolLocal
wkb_Txt.Close savechanges:=False
Set wkb_Txt = Nothing
Application.DisplayAlerts = True
If bolRename = True Then
If Dir(strPfad & wks.Name & ".txt") "" Then
VBA.Kill strPfad & wks.Name & ".txt"
End If
Name strPfad & wks.Name & strExt As strPfad & wks.Name & ".txt"
End If
fncSave_as_Text = True
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkb_Txt Is Nothing Then
wkb_Txt.Close savechanges:=False
End If
End Select
End With
End Function