VBA - Exportieren von bestimmten Daten aus einer Tabelle

[Konsti19]

Hallo Forum,
ich habe eine Tabelle und möchte für bestimmte Werte verschiedene TXT-Datein exportieren. 

BSP: 
ID    BARCODE    Info1    Info2 
1           15             xxx      yyy          
2           16           xxx      yyy        
3           17             xxx       yyy         
1           18             xxx       yyy         
2           19             xxx       yyy        

Nach ausführen des Makros hätte ich gerne für jede ID eine exportierte TXT Datei.

Bsp:

Erste TXT Datei mit dem Namen ID=1:

ID    BARCODE    Info1      Info2   
1           15             xxx      yyy          

1           18             xxx      yyy        



Zweite TXT Datei mit dem Namen ID=2:



ID    BARCODE    Info1    Info2    
2           16           xxx      yyy       
2           19           xxx      yyy   



usw... 



Ich hab leider keine Idee wie ich anfangen kann dieses Makro zu bauen... gibt es jmd mit einem ähnlichem Problem oder weiß jmd wo ich suchen kann? 



mfg 

Konsti

[Stoffo]

Hallo,

kurzes googlen liefert:
Link1

Link2 (separate Excel)-Dateien
Link3

[schauan]

Hallöchen,

Du könntest ein Makro aufzeichnen und mit dem Autofilter arbeiten. Im Prinzip Filtern - Gefilterte Daten kopieren - Kopierte Daten als txt speichern.
Siehe zur Makroaufzeichnung die Hilfe in Excel-Word-Makrorekorder

[Konsti19]

Hey vielen Dank für eure Hilfe! 
Ich habe folgenden Code zusammengebastelt...(war mein erster Code) 

Leider habe ich noch zwei Probleme: 

1. Der Code erkennt nicht die letzte Zelle in Spalte A, da die Werte in dieser  Spalte aus Formeln abgeleitet werden. (=WENN(ISTLEER(Metadatenliste!A17);"";Metadatenliste!A17))
Was kann ich in meinem Code ändern um die letzte gefüllte Zelle zu erkennen? 

2. Ich weiß nicht wie ich es schaffe, das alle gleichen Werte in der Spalte A auch in einer Textdatei zusammengefasst werden, aktuell bekomme ich noch für jeden Wert eine eigene Textdatei.

Code:

Code:

Sub EXPORT()
    Dim strPath As String, cell As Range
   
    strPath = ActiveWorkbook.Path
   
    Dim newPath As String
   
    Application.ScreenUpdating = False
   
    newPath = strPath & "\" & Format(Date, "YYYY_MM_DD")
    MkDir newPath
   
    With ActiveSheet
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
            .Range("1:1," & cell.Row & ":" & cell.Row).Copy
           
            With Workbooks.Add
                .Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=False
                .SaveAs newPath & "\" & cell.Value, FileFormat:=xlText
                .Close
            End With
        Next
    End With
    Application.ScreenUpdating = True
   
    'MsgBox "Fertig exportiert"
   
   Shell "explorer.exe """ & newPath & """", vbNormalFocus
   
End Sub

[volti]

Hallo Konsti,

wenn Du nur Texte in Textdateien exportieren möchtest und Du die Konstellation hast, dass mehrere ggf. nicht untereinander stehende Zeilen in einer Textdatei zusammengefasst werden sollen, würde ich das direkt mit VBA ohne Paste usw. machen.

Schau mal, ob anliegender Code in Deinem Sinne funktioniert. Ich habe auch, obwohl ich nicht weiß, ob es gewünscht ist, auch in jeder Textdatei den gleichen Kopf miteinfügen lassen. Den Part kannst Du ja bei Missfallen entfernen:

Bitte beachten, dass bei Mehrfach laufen lassen, alle Daten erweiternd unten angefügt werden. Also ggf. vorher die Dateien weglöschen (lassen).

Code:

Option Explicit

Sub EXPORT()
 Dim strPath As String, Zelle As Range, i As Long
 Dim sData As String, sKopfdata As String, sFilename As String
 Dim newPath As String

 strPath = ActiveWorkbook.Path
  
 Application.ScreenUpdating = False
  
 newPath = strPath & "\" & Format(Date, "YYYY_MM_DD")
 On Error Resume Next
 ChDir newPath
 MkDir newPath
  
 With ActiveSheet
  For Each Zelle In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
    If Zelle.Value <> "" Then
     sFilename = newPath & "\" & Zelle.Value & ".txt"
     Close #1
     sKopfdata = ""

'Kopfdaten ermitteln
     If Dir$(sFilename) = "" Then
        For i = 1 To .UsedRange.Columns.Count
           sKopfdata = sKopfdata & .Cells(1, i).Value & vbTab
        Next i
     End If
     Open sFilename For Append As #1

'Kopfdaten schreiben
     If sKopfdata <> "" Then
        Print #1, Left$(sKopfdata, Len(sKopfdata) - 1)
     End If

'Daten schreiben
     sData = ""
     For i = 1 To .UsedRange.Columns.Count
         sData = sData & .Cells(Zelle.Row, i).Value & vbTab
     Next i
    
     Print #1, Left$(sData, Len(sData) - 1)
     Close #1
    
    End If
  Next
 End With
 
 Application.ScreenUpdating = True
  
 MsgBox "Fertig exportiert"
  
 Shell "explorer.exe """ & newPath & """", vbNormalFocus
  
End Sub

_______________

viele Grüße aus Freigericht
Karl-Heinz

[volti]

Hallo Konsti,

hier noch ein kleines Update mit einem anderen Verzeichniserstellungscode. Da nichts in die Tabelle geschrieben wird, brauchst Du Application.Screenupdating auch nicht.

Code:

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
        ByVal lpPath As String) As Long

Sub EXPORT()
 Dim Zelle As Range, i As Long
 Dim sData As String, sKopfdata As String, sFilename As String
 Dim sNewPath As String
  
 sNewPath = ActiveWorkbook.Path & "\" & Format(Date, "YYYY_MM_DD") & "\"
 MakeSureDirectoryPathExists sNewPath   'Verzeichnispfad anlegen
  
 With ActiveSheet
  For Each Zelle In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
    If Zelle.value <> "" Then
     sFilename = sNewPath & Zelle.value & ".txt"
     Close #1
     sKopfdata = ""

'Kopfdaten ermitteln
     If Dir$(sFilename) = "" Then
        For i = 1 To .UsedRange.Columns.Count
           sKopfdata = sKopfdata & .Cells(1, i).value & vbTab
        Next i
     End If
     Open sFilename For Append As #1

'Kopfdaten schreiben
     If sKopfdata <> "" Then
        Print #1, Left$(sKopfdata, Len(sKopfdata) - 1)
     End If

'Daten schreiben
     sData = ""
     For i = 1 To .UsedRange.Columns.Count
         sData = sData & .Cells(Zelle.Row, i).value & vbTab
     Next i
    
     Print #1, Left$(sData, Len(sData) - 1)
     Close #1
    
    End If
  Next
 End With
 
  
 MsgBox "Fertig exportiert"
  
 Shell "explorer.exe """ & sNewPath & """", vbNormalFocus
  
End Sub

_______________

viele Grüße aus Freigericht
Karl-Heinz

[Konsti19]

Viel Danke! Das ist super!