Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA für jede Zeile einzelne Textdatei erzeugen

VBA für jede Zeile einzelne Textdatei erzeugen
29.03.2017 14:34:43
Stefanie
Hallo zusammen,
ich befinde mich zurzeit im Praxissemester und habe für mich eine sehr komplexe Aufgabe bekommen:
Ich habe eine Datei, zu der für jede Zeile eine neue Textdatei erzeugt werden soll.
Diese sollen dann alle in einem Ordner gespeichert werden.
Ich habe es soweit hinbekommen, dass bei jedem Schleifendurchlauf eine Textdatei erzeugt wird, allerdings ist diese gefüllt mich chinesischen Zeichen ? :D
Außerdem gibt es noch die Nebenbedingung, dass wenn in Spalte 1, untereinander zwei oder mehrere gleiche Werte sind, diese in eine Textdatei gepackt werden und nicht extra Textdateien erzeugt werden.
Ich wäre euch wirklich sehr hilfreich, wenn ihr mir helfen könntet.
Am Mittwoch kommt eine externe Firma, denen ich das vorstellen muss ..
Liebe Grüße :*

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 3 Fragen tiefer
29.03.2017 14:40:40
Fennek
Hi,
eine ähnliche Frage wurde heute schon einmal gestellt.
Ohne eine kleine Bsp-Datei ist es schwer zu sagen, was verbessert werden sollte.
mfg
AW: VBA für jede Zeile einzelne Textdatei erzeugen
30.03.2017 08:23:58
Stefanie
Oh ja sorry, dass habe ich total vergessen ..
Also in der oberen Datei werden genau die Spalten ausgegeben, die ich benötige, das funktioniert und im unteren Teil wird bei jedem SChleifendurchlauf eine Textdatei erzeugt, ich habe hier nur 3 angegeben aber eigentlich soll für jede Zeile eine erzeugt werden.
Ganz unten habe ich versucht die beiden Codes miteinander zu verknüpfen, aber es funktioniert nicht ..
Was kann ich an dem Code verbessern oder anders machen ?
Liebe Grüße :*
'**********************************Gibt die richtigen Spalten aus ************************************************
Sub imaSchnittstelle()
'Variablen deklarieren
Dim i As Long
Dim Pfad As String
Dim TD As Integer
Dim sLine As Variant
Application.DisplayAlerts = False 'Bildschirmaktualisierungen ausschalten, Makro wird schneller  _
ausgeführt und Bildschirm flackert nicht
lz = Sheets("KFL_allePrgr_23032017").UsedRange.SpecialCells(xlCellTypeLastCell).Row 'ermittelt  _
die letzte Zeile des Tabellenblattes
Pfad = "C:\Desktop\Test.txt" 'Hier wird die Datei gespeichert: kann geändert werden
TD = FreeFile() 'gibt Wert von Typ Integer zurück, der nächste verfügbare Dateinummer darstellt
'Öffnet die Datei zum reinschreiben
Open Pfad For Output As TD 'kann auch Append benutzt werden: Output überschreibt vorhandene  _
Datei & Append fügt neue Zeile hinzu
'Schleife: Anweisung wird von Zeile 9 bis zur letzten Zeile durchgeführt
For i = 9 To lz
Print #TD, Cells(i, 1) & ";" & Cells(i, 10) & ";" & Cells(i, 10) & ";" & Cells(i, 18) & ";" &  _
Cells(i, 17) & ";" & Cells(i, 5) & ";" & Cells(i, 9) & ";" & Cells(i, 16) & ";" & Cells(i, 11) & ";" & Cells(i, 20) & ";" & Cells(i, 21)
Next i 'nächste Zeile
Application.DisplayAlerts = True 'Bildschirmaktualisierungen wieder einschalten
MsgBox "Die Textdateien wurden im Verzeichnis ... gespeichert !" 'Benachrichtigungsfenster am  _
Ende des  Makros
End Sub

'**********************************Erstellt bei jedem Schleifendurchlauf eine Textdatei******************************************
Sub WorksheetsErstellenSchleife()
'Datei erstellen
Dim i As Integer
Dim Pfad As String
Pfad = "C:\Desktop"
For i = 1 To 3
Workbooks.Add
With ActiveWorkbook
.SaveAs Pfad & "Test" & i & ".txt"
'.Worksheets("Tabelle1").Cells(1, 1).Value = "Test"
.Close True
End With
Next
End Sub
__________________________________
Sub imaSchnittstelle()
'Variablen deklarieren
Dim i As Long
Dim Pfad As String
Dim TD As Integer
Dim sLine As Variant
Dim m As Integer
Application.DisplayAlerts = False 'Bildschirmaktualisierungen ausschalten, Makro wird schneller  _
ausgeführt und Bildschirm flackert nicht
lz = Sheets("KFL_allePrgr_23032017").UsedRange.SpecialCells(xlCellTypeLastCell).Row 'ermittelt  _
die letzte Zeile des Tabellenblattes
Pfad = "C:\Desktop\Test.txt" 'Hier wird die Datei gespeichert: kann geändert werden
TD = FreeFile()
'Öffnet die Datei zum reinschreiben
Open Pfad For Output As TD 'kann auch Append benutzt werden: Output überschreibt vorhandene  _
Datei & Append fügt neue Zeile hinzu
'Schleife: Anweisung wird von Zeile 9 bis zur letzten Zeile durchgeführt
For i = 9 To lz
Workbooks.Add
With ActiveWorkbook
.SaveAs Pfad & "TestTest" & i & ".txt"
.Worksheets("KFL_allePrgr_23032017").Cells(1, 1).Value = "Test"
.Close False
Print #TD, Cells(i, 1) & ";" & Cells(i, 10) & ";" & Cells(i, 10) & ";" & Cells(i, 18) & ";" &  _
Cells(i, 17) & ";" & Cells(i, 5) & ";" & Cells(i, 9) & ";" & Cells(i, 16) & ";" & Cells(i, 11) & ";" & Cells(i, 20) & ";" & Cells(i, 21)
Next i 'nächste Zeile
Application.DisplayAlerts = True 'Bildschirmaktualisierungen wieder einschalten
MsgBox "Die Textdateien wurden im Verzeichnis ... gespeichert !" 'Benachrichtigungsfenster am  _
Ende des  Makros
End Sub

Anzeige
AW: auf die Schnelle
30.03.2017 08:56:59
Fennek
Hallo,
in einem Text-Editor habe ich den Code etwas umgeschrieben, bis auf "close #1" sollte die Syntax stimmen.

Sub imaSchnittstelle()
lz = Sheets("KFL_allePrgr_23032017").cells(rows.count,"A").end(xlup).row
Pfad = "C:\Desktop\"
for i = 9 to lz
Open Pfad & "Test" & i & ".txt" For Output As #1
Print #1, Cells(i, 1) & ";" & Cells(i, 10) & ";" & Cells(i, 10) & ";" & Cells(i, 18) & ";" &  _
Cells(i, 17) & ";" & Cells(i, 5) & ";" & Cells(i, 9) & ";" & Cells(i, 16) & ";" & Cells(i, 11) & _
";" & Cells(i, 20) & ";" & Cells(i, 21)
close #1
Next i 'nächste Zeile
End Sub
Die ursprünglich genannte Bedingung "alle Zellen eines Falls zusammen zu speichern" ist nicht berücksichtigt, das würde auch einen völlig anderen Ansatz erfordern.
mfg
Anzeige
AW: auf die Schnelle
30.03.2017 09:08:05
Stefanie
Hallo Fennek, vielen vielen vieeeelen Dank !
Ich sitze schon seit Tagen dran und nur die paar Zeilen Code waren eig die Lösung, unglaublich :D
Danke !
Ja, dass mit der Nebenbedingung hatte ich noch nicht berücksichtigt, weil ich das andere noch nicht hinbekommen hatte ..
Dann setz ich mich jetzt mal da dran ..
Melde mich, wenn ich da nicht weiterkommen, hoffe kannst mir da auch helfen :)
Wunderschönen Tag wünsche ich dir :)
AW: VBA für jede Zeile einzelne Textdatei erzeugen
30.03.2017 14:36:06
Stefanie
Hallo, ich habe es leider nicht geschafft.
Das bezieht sich nur auf die Spalte 1:
Wenn zwei oder mehrere Werte untereinander gleich sind, dann sollen diese in eine Textdatei gepackt werden.
 If AcitveCell = ActiveCell + 1 Then 

So sieht momentan mein Ansatz aus, aber ich komme bei diesem Then nicht weiter
Außerdem weiß ich auch nicht, ob dieses ActiveCell + 1 genau das bewirkt, was ich möchte. Ich möchte die darunterliegenden Zellen vergleichen ?
Kann mir BITTE jemand helfen ?
Lg
Anzeige
AW: VBA für jede Zeile einzelne Textdatei erzeugen
30.03.2017 14:57:43
Fennek
Hallo,
abgesehen von der Rechtschreibung
If AcitveCell = ActiveCell + 1 Then
wäre besser
if activecell = activecell.offset(1) then
mfg
AW: VBA für jede Zeile einzelne Textdatei erzeugen
30.03.2017 15:15:43
Stefanie
Oh, okay danke :grins:
Jetzt vergleiche ich ja untereinander liegende Zeilen, aber ist das dann nicht "verallgemeinert" ?
Weil, es sollen ja nur die Zellen in der ersten Spalte verglichen werden. Oder steht die 1 in der Klammer für die erste Spalte ?
Und wie kann ich diese Zeilen jetzt in einer Textdatei zusammenfassen ?
Bzw. wie kann ich in meinem Code schreiben, dass wenn in der ersten Spalte, die Zeile darunter = der oberen Zeile ist, dass ich diese Zeile(n) in die vorherige Textdatei schreibe und nicht noch eine erzeuge ?
Liebe Grüße :)
Anzeige
AW: VBA für jede Zeile einzelne Textdatei erzeugen
03.04.2017 14:27:25
Jürgen
Hallo Stefanie,
ein kleiner Ideenansatz ohne Prüfung!
Speichere die Textdateien doch beginnen mit dem Wert aus Spalte "A" ab.
Suche anschließend in der For-Schleife, ob eine Datei im Verzeichnis mit dem Wert beginnt.
in der Schleife aufrufen:
 Call SearchInFolder(Suchverzeichnis, Range("A" & i).value & "*")

Ein Unter-Sub in der Exceldatei zum suchen:

Private Sub SearchInFolder(ByVal Folderspec As String, Suchwert As String)       ' auslesen  _
aufrufen mit Ordnername
Dim StTyp As String
Dim FSO As Object
Dim FI As Object
Dim strdatei2 As String
Set FSO = CreateObject("Scripting.Filesystemobject")
If Not FSO.FolderExists(Folderspec) Then
MsgBox Folderspec & " ist nicht vorhanden."
Set FSO = Nothing
Exit Sub
End If
StTyp = "xls" ' Dateityp
'Dateien auslesen
For Each FI In FSO.GetFolder(Folderspec).Files           ' Schleife über alle Dateien
'Dateityp feststellen
If FI.Name Like Suchwert Then
strDatei = FI.Name
Exit Sub 'anpassen
End If
Next
Set FSO = Nothing
End Sub
Dabei kann das Suchverzeichnis fest hinterlegt werden, oder wie ich es gerne ausführe durch die Abfrage einer MsgBox variabel gestaltet werden.
Gruß
Jürgen
Anzeige

160 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige