funserver
Goto Top

Excel Makro Export in eine CSV Datei

Hallo, ich möchte eine Exceltabelle mittels Makro in einen Pfad mit festem Dateinamen exportieren.
Hierzu gibt es schon folgenden Code:

Sub TestRange()
Dim ws As Worksheet, fd As FileDialog, rngTest As Range, rngExport As Range, fltr As FileDialogFilter
'Worksheet auf dem die Daten stehen
Set ws = Worksheets(1)
'Zelle die auf Inhalt überprüft werden soll
Set rngTest = ws.Range("N7")
'Bereich der exportiert wird
Set rngExport = ws.Range("A7:S45")
If rngTest.Text <> "" Then
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.Title = "Wählen sie einen Namen unter der die CSV-Datei gespeichert werden soll"
'Filterindex für CSV-Dateien ermitteln
For i = 1 To .Filters.Count
If .Filters(i).Extensions = "vis_order.csv" Then
.FilterIndex = i
Exit For
End If
Next
'Wenn OK geklickt wurde starte Export
If .Show = True Then
ExportRangeAsCSV rngExport, ";", .SelectedItems(1)
End If
End With
End If
End Sub
'Prozedur für den Export eines Ranges in eine CSV-Datei
Sub ExportRangeAsCSV(ByVal rng As Range, delim As String, filepath As String)
Dim arr As Variant, line As String, csvContent As String, fso As Object, csvFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set csvFile = fso.OpenTextFile(filepath, 2, True)
arr = rng.Value
If IsArray(arr) Then
'If arr(1, 14) <> "" Then
For r = 1 To UBound(arr, 1)
line = ""
If arr(r, 14) <> "" Then 'Wenn Inhalt in Spalte N
For c = 1 To UBound(arr, 2)
If c < UBound(arr, 2) Then
line = line & "" & arr(r, c) & "" & delim
Else
line = line & "" & arr(r, c) & ""
End If
Next
'End If
csvContent = csvContent & line & vbNewLine
End If
Next
csvFile.Write (csvContent)
csvFile.Close
Else
MsgBox "Bereich besteht nur aus einer Zelle!", vbExclamation
'End If
End If
Set fso = Nothing
Set csvFile = Nothing
End Sub

IN dem vorliegenden Code funktioniert das ganze schon allerdings muss beim ausführen immer der Pfad und die Datei manuell ausgewählt werden, das möchte ich automatisieren.
Kann mir hierzu noch jemand helfen ?
Vielen Dank

Content-Key: 438387

Url: https://administrator.de/contentid/438387

Printed on: April 19, 2024 at 11:04 o'clock

Member: em-pie
em-pie Apr 08, 2019 at 18:17:21 (UTC)
Goto Top
Moin,

Zwei Dinge:
1. nutze hier die Code-Tags
2. schaue dir die Zeile mit dem folgenden Code an:

Set fd = Application.FileDialog(msoFileDialogSaveAs)

Die richtig ersetzen und es sollte laufen


Gruß
em-pie
Mitglied: 139374
Solution 139374 Apr 08, 2019 updated at 19:14:36 (UTC)
Goto Top
Er hat's immer noch nicht kapiert deswegen auch so unformatiert zurück

Sub TestRange()
Dim ws As Worksheet, rngTest As Range, rngExport as Range
'Worksheet auf dem die Daten stehen
Set ws = Worksheets(1)
'Zelle die auf Inhalt überprüft werden soll
Set rngTest = ws.Range("N7")
'Bereich der exportiert wird
Set rngExport = ws.Range("A7:S45")
If rngTest.Text <> "" Then
ExportRangeAsCSV rngExport, ";", "d:\jajetztjaeineInsel.csv"
End If
End Sub
'Prozedur für den Export eines Ranges in eine CSV-Datei
Sub ExportRangeAsCSV(ByVal rng As Range, delim As String, filepath As String)
Dim arr As Variant, line As String, csvContent As String, fso As Object, csvFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set csvFile = fso.OpenTextFile(filepath, 2, True)
arr = rng.Value
If IsArray(arr) Then
'If arr(1, 14) <> "" Then
For r = 1 To UBound(arr, 1)
line = ""
If arr(r, 14) <> "" Then 'Wenn Inhalt in Spalte N
For c = 1 To UBound(arr, 2)
If c < UBound(arr, 2) Then
line = line & "" & arr(r, c) & "" & delim
Else
line = line & "" & arr(r, c) & ""
End If
Next
'End If
csvContent = csvContent & line & vbNewLine
End If
Next
csvFile.Write (csvContent)
csvFile.Close
Else
MsgBox "Bereich besteht nur aus einer Zelle!", vbExclamation
'End If
End If
Set fso = Nothing
Set csvFile = Nothing
End Sub
Member: FunServer
FunServer Apr 08, 2019 at 20:16:35 (UTC)
Goto Top
Zuerst,der Code funktioniert super, danke.

jetzt muss ich die Kritik an mich mal testen:
Sub TestRange()
 Dim ws As Worksheet, rngTest As Range, rngExport as Range
 'Worksheet auf dem die Daten stehen  
 Set ws = Worksheets(1)
 'Zelle die auf Inhalt überprüft werden soll  
 Set rngTest = ws.Range("N7")  
 'Bereich der exportiert wird  
 Set rngExport = ws.Range("A7:S45")  
Member: Meierjo
Meierjo Apr 09, 2019 at 04:45:12 (UTC)
Goto Top
Hallo

IN dem vorliegenden Code funktioniert das ganze schon allerdings muss beim ausführen immer der Pfad und die Datei manuell ausgewählt werden, das möchte ich automatisieren.

Hättest du auch gleich in deinem 1. Post melden können, wäre im selben Aufzug gelöst worden

Gruss
Member: FunServer
FunServer Apr 10, 2019 at 18:26:19 (UTC)
Goto Top
Hallo Meierjo,
da gebe ich Dir recht allerdings hate ich die Idee erst im Nachgang.
Gruß