aus Daten Tabelle einzelne TXT Datei erstellen

[kappe855]

Hallo in die Runde,

vielleicht kann mir jemand helfen...
Ich bin ein ziemlicher Anfänger und kann mir nur bedingt hin und wieder mit dem Makro Recorder helfen.

Ich habe eine Excel Datei mit zwei Spalten. 
Daraus sollen einzelne TXT Dateien abhängig von dem Wert aus Spalte B entstehen
in den jeweiligen TXT Dateien soll dann aber nur der dazugehörige Wert aus Spalte A stehen.

Spalte B kann bis zu 21 verschiedene Werte enthalten, dies ist aber nicht immer der Fall (10, 21, 31, 40, 41, 45 usw...)
Es müssen also bis zu 21 TXT Dateien erstellt werden, der Name diese Dateien sollte dann ebenfalls 10, 31, 34...
lauten je nachdem welche Werte vorhanden sind.

Beispiel:
10.txt    21.txt
A005      D584
A478      O147
S451      Z652 usw.

Eine Beispieldatei hänge ich mit an, hir sind sogar alle 21 möglichen Werte aus Spalte B vorhanden

Ich würde mich sehr freuen, wenn ich das mit eurer Hilfe gelöst bekomme.

Derweil noch einen schönen Sonntag

[ralf_b]

Hier eine Lösung. Es wird noch Spalte X für die Erstellung einer eindeutigen Liste aus Spalte B benutzt. Falls diese und die beiden angrenzenden Spalten bei dir nicht frei sind, dann mußt du die Spalte X im Code anpassen. In den Dateien gibt es auch keine doppelten Einträge. 
Dateien, die schon vorhanden sind werden ignoriert. 
Ohne Garantie!

Code:

Sub filterB_FileExportA()

    Dim rngB As Range
    Dim arrFilter, arrData
    Dim i As Long, cnt As Loneg
    Dim intFF
    Dim sWert As String

    With Tabelle1
        Set rngB = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
        arrData = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
   
        .Range("x1").Resize(rngB.Rows.Count).Value = rngB.Value
        .Range("x:x").CurrentRegion.RemoveDuplicates 1, xlNo
        arrFilter = .Range("x1").CurrentRegion
        .Range("x1").CurrentRegion.ClearContents
    
        For i = LBound(arrFilter) To UBound(arrFilter)
        
            If Dir(ThisWorkbook.Path & "\" & arrFilter(i, 1) & ".txt") = "" Then
                sWert = ""
                For cnt = LBound(arrData) To UBound(arrData)
                    If arrFilter(i, 1) = arrData(cnt, 2) And InStr(sWert, arrData(cnt, 1)) = 0 Then
                        sWert = sWert & vbLf & arrData(cnt, 1)
                    End If
                Next
                sWert = Replace(sWert, vbLf, "", 1, 1, vbTextCompare)
                ' Öffnet oder erstellt Textdatei zum hineinschreiben
                intFF = FreeFile
                Open ThisWorkbook.Path & "\" & arrFilter(i, 1) & ".txt" For Output As #intFF
              
                Print #intFF, sWert            ' Zeile in TXTDatei schreiben
                Close #intFF                     ' schließt die Textdatei
            End If
        Next
   
    End With
   
    Set rngB = Nothing: Erase arrData: Erase arrFilter
   
    MsgBox "Dateien wurde erstellt"
End Sub

[kappe855]

Hallo Ralf,

danke für deine Hilfe, in der Spalte X habe ich nichts stehen, nur in A und B
ich habe es eben getestet funktioniert bis auf die Sache das doppelte Werte ignoriert werden super, habe lediglich das "g" entfernt

Code:

cnt As Loneg

Leider benötige ich auch die besagten doppelten Werte, wäre es dir möglich den Code nochmal etwas anzupassen?

Ich wäre dir sehr Dankbar

[ralf_b]

Code:

Option Explicit

Sub filterB_FileExportA()

    Dim rngB As Range
    Dim arrFilter, arrData
    Dim i As Long, cnt As Long
    Dim intFF
    Dim sWert As String

    With Tabelle1
        Set rngB = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
        arrData = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
   
        .Range("x1").Resize(rngB.Rows.Count).Value = rngB.Value
        .Range("x:x").CurrentRegion.RemoveDuplicates 1, xlNo
        arrFilter = .Range("x1").CurrentRegion
        .Range("x1").CurrentRegion.ClearContents
     
        For i = LBound(arrFilter) To UBound(arrFilter)
         
            If Dir(ThisWorkbook.Path & "\" & arrFilter(i, 1) & ".txt") = "" Then
                sWert = ""
                For cnt = LBound(arrData) To UBound(arrData)
                    If arrFilter(i, 1) = arrData(cnt, 2) Then  'And InStr(sWert, arrData(cnt, 1)) = 0 Then
                        sWert = sWert & vbLf & arrData(cnt, 1)
                    End If
                Next
                sWert = Replace(sWert, vbLf, "", 1, 1, vbTextCompare)
                ' Öffnet oder erstellt Textdatei zum hineinschreiben
                intFF = FreeFile
                Open ThisWorkbook.Path & "\" & arrFilter(i, 1) & ".txt" For Output As #intFF
               
                Print #intFF, sWert            ' Zeile in TXTDatei schreiben
                Close #intFF                     ' schließt die Textdatei
            End If
        Next
   
    End With
   
    Set rngB = Nothing: Erase arrData: Erase arrFilter
   
    MsgBox "Dateien wurde erstellt"
End Sub

[kappe855]

Danke, genau was ich benötige

[kappe855]

Hallo Ralf,

jetzt muss ich doch nochmal stören...

Ich habe nun ein Problem beim Weiterverarbeiten der erstellten txt Dateien

Wenn ich die txt im Editor öffne stehen alle Werte wie gewollt untereinander

So wie, wenn ich das manuell aus der Excel Datei in die txt kopiere.

Aber

Bei meinem externen Programm, das die txt ausliest, wird mir das ganze so angezeigt

O094SO093MN031SN201L

Bei der manuellen Erstellung/Speicherung der txt bekomme ich das Ergebnis.

O094S
O093M
N031S
N201L

Nur so kann ich die Daten aus der txt weiter verarbeiten.

Kann es sein das bei deinem Code keine Zeilenumbrüche mit gespeichert werden?

Ich habe das manuelle Speichern mal als Makro aufgezeichnet, da bekomme ich diese Zeilen angezeigt.. Ich weiß nicht, ob das weiterhilft.

Code:

ActiveWorkbook.SaveAs Filename:="C:\Desktop\10.txt", _

FileFormat:=xlTextMSDOS, CreateBackup:=False

Ich versuche seit ein paar Stunden die Zeilen in deinen Code zu integrieren aber leider ohne Erfolg,

hast du vielleicht nochmal eine Idee oder kennst das Problem?

Gruß Andreas

[ralf_b]

versuch mal in dem du vblf durch vbcrlf ersetzt im Code.

Vbcrlf  Chr(13) + Chr(10)   Wagenrücklauf-Zeilenumbruch-Kombination
vbCr Chr(13)  Wagenrücklaufzeichen
Vblf Chr(10) Zeilenvorschubzeichen

[schauan]

Hallöchen,

Da stimme ich Ralf zu. Texteditoren kennen zumeist nur CRLF als Zeilentrenner.

[kappe855]

versuch mal in dem du vblf durch vbcrlf ersetzt im Code.

Das war ein Volltreffer! Danke