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
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
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
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
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
Viel Danke! Das ist super!