Excel Makro in CSV exportieren

Hallo, ich habe hier einen VBA Code der einen bestimmten Range wenn die Spalte N7 belegt ist in eine CSV Exportiert.

Den Code würde ich gerne so erweitern, das nur die Zeilen Exportiert werden, wenn in der Spalte "N" ein Wert steht, die Zeilen der Spalte N die keinen Wert haben werden nicht exportiert.

Anbei der 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
For r = 1 To UBound(arr, 1)
line = ""
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
csvContent = csvContent & line & vbNewLine
Next
csvFile.Write (csvContent)
csvFile.Close
Else
MsgBox "Bereich besteht nur aus einer Zelle!", vbExclamation
End If
Set fso = Nothing
Set csvFile = Nothing
End Sub

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 437842

Url: https://administrator.de/forum/excel-makro-in-csv-exportieren-437842.html

Ausgedruckt am: 19.02.2025 um 23:02 Uhr

4 Kommentare

Neuester Kommentar

Dafür gibt's den AutoFilter
https://docs.microsoft.com/de-de/office/vba/api/excel.range.autofilter

Hallo

Etwa so

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