Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.10.2025 08:21:40
24.10.2025 18:10:41
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Forumthread: Werte in .txt schreiben

Werte in .txt schreiben
Horst
Liebe Excel-Freunde!
Wie kann ich in folgendem VBA-Code angeben, dass der Inhalt der 132. Spalte in eine eigene .txt geschrieben wird? Die im Makro angegebenen Autofilter-Optionen (siehe Spalte 126 und 134) sowie die gesamte übrige Prozedur sollen dabei erhalten bleiben - es soll einfach nur eine zusätzliche .txt, z.b. "signal.txt" mit den gefilterten Werten der 132. Spalte erzeugt werden.
Besten Dank vorab, Horst
Option Explicit
Sub signalgen_one()
Dim oApp As Excel.Application, oWB_Ex As Workbook
Dim iCalc%
Dim sPath$, File_Test$, File_Train$, File_ReTrain$, File_XLX$
Dim tmpWS As Worksheet
Dim lngMaxRow&, nCount&, sString$, strInfo$
Dim F%
sPath$ = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
File_XLX = sPath & "results.xls" 'evtl. Pfad anpassen
File_Test = sPath & "test_one.txt" 'evtl. Pfad anpassen
File_Train = sPath & "train_one.txt" 'evtl. Pfad anpassen
File_ReTrain = sPath & "retrain_one.txt" 'evtl. Pfad anpassen
'Text- File löschen, evtl. Zeilen löschen wenn nicht gewünscht
If Dir(File_Test, vbNormal)  "" Then Kill File_Test
If Dir(File_Train, vbNormal)  "" Then Kill File_Train
If Dir(File_ReTrain, vbNormal)  "" Then Kill File_ReTrain
On Error GoTo ErrorHandler:
Set oApp = New Excel.Application
oApp.Visible = False 'evtl. auf True setzen, wenn der Vorgang sichbar sein soll
oApp.Workbooks.Open "C:\Programme\Signal_Pro\update\signal_db.xls", ReadOnly:=True
Set oWB_Ex = oApp.Workbooks.Open(File_XLX, True, True)
iCalc = oApp.Calculation
oApp.EnableEvents = False
oApp.Calculation = xlCalculationManual
oApp.DisplayAlerts = False
With oWB_Ex
Set tmpWS = .Sheets.Add
With .Sheets("results")
.UsedRange.AutoFilter Field:=134, Criteria1:="1"
.UsedRange.AutoFilter Field:=126, Criteria1:=" 1 Then
With Application
F = FreeFile
Open File_Test For Append As #F
sString = Join(.Transpose(.Transpose(tmpWS.UsedRange.Rows(lngMaxRow))), vbTab)
Print #F, sString
Close #F
strInfo$ = Chr(149) & " " & Mid$(File_Test, InStrRev(File_Test, "\") + 1, Len(File_Test) _
) & vbCr
lngMaxRow = lngMaxRow - 1
If lngMaxRow > 1 Then
Open File_ReTrain For Append As #F
nCount = .Max(2, lngMaxRow - 49)
For lngMaxRow = nCount To lngMaxRow
sString = Join(.Transpose(.Transpose(tmpWS.UsedRange.Rows(lngMaxRow))),  _
vbTab)
Print #F, sString
Next lngMaxRow
Close #F
strInfo$ = strInfo$ & Chr(149) & " " & Mid$(File_ReTrain, InStrRev(File_ReTrain, "\" _
) + 1, Len(File_ReTrain)) & vbCr
End If
nCount = nCount - 1
If nCount > 1 Then
Open File_Train For Append As #F
For lngMaxRow = 2 To nCount
sString = Join(.Transpose(.Transpose(tmpWS.UsedRange.Rows(lngMaxRow))),  _
vbTab)
Print #F, sString
Next lngMaxRow
Close #F
strInfo$ = strInfo$ & Chr(149) & " " & Mid$(File_Train, InStrRev(File_Train, "\") +  _
1, Len(File_Train)) & vbCr
End If
End With
End If
ErrorHandler:
If iCalc  0 Then oApp.Calculation = iCalc
oApp.Quit
Set oApp = Nothing
If Err.Number  0 Then
MsgBox Err.Description, vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
Else
MsgBox "Text- Files geschrieben!" & vbCr & vbCr & Left$(strInfo, Len(strInfo) - 1),  _
vbInformation
End If
End Sub

Anzeige

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Werte in .txt schreiben
30.06.2012 23:20:01
fcs
Hallo Horst,
ich hoffe ich hab das richtig verstanden.
Das zusätzliche Textfile wird jetzt als 1. File erzeugt.
Die neuen/anzupassenden Zeilen sind markiert.
Gruß
Franz
Option Explicit
Sub signalgen_one()
Dim oApp As Excel.Application, oWB_Ex As Workbook
Dim iCalc%
Dim sPath$, File_Test$, File_Train$, File_ReTrain$, File_XLX$
Dim File_Signal$                                                '#### neu
Dim tmpWS As Worksheet
Dim lngMaxRow&, nCount&, sString$, strInfo$
Dim F%
sPath$ = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
File_XLX = sPath & "results.xls" 'evtl. Pfad anpassen
File_Test = sPath & "test_one.txt" 'evtl. Pfad anpassen
File_Train = sPath & "train_one.txt" 'evtl. Pfad anpassen
File_ReTrain = sPath & "retrain_one.txt" 'evtl. Pfad anpassen
File_Signal = sPath & "signal_one.txt" 'evtlName anpassen         '#### neu
'Text- File löschen, evtl. Zeilen löschen wenn nicht gewünscht
If Dir(File_Test, vbNormal)  "" Then Kill File_Test
If Dir(File_Train, vbNormal)  "" Then Kill File_Train
If Dir(File_ReTrain, vbNormal)  "" Then Kill File_ReTrain
If Dir(File_Signal, vbNormal)  "" Then Kill File_Signal          '#### neu
On Error GoTo ErrorHandler:
Set oApp = New Excel.Application
oApp.Visible = False 'evtl. auf True setzen, wenn der Vorgang sichbar sein soll
oApp.Workbooks.Open "C:\Programme\Signal_Pro\update\signal_db.xls", ReadOnly:=True
Set oWB_Ex = oApp.Workbooks.Open(File_XLX, True, True)
iCalc = oApp.Calculation
oApp.EnableEvents = False
oApp.Calculation = xlCalculationManual
oApp.DisplayAlerts = False
With oWB_Ex
Set tmpWS = .Sheets.Add
With .Sheets("results")
.UsedRange.AutoFilter Field:=134, Criteria1:="1"
.UsedRange.AutoFilter Field:=126, Criteria1:=" 1 Then
With Application
F = FreeFile
'### neu Anfang - Daten aus Spalte 128 in ein Textfile schreiben
Open File_Signal For Append As #F
For nCount = 2 To lngMaxRow
sString = tmpWS.Cells(nCount, 132).Text
Print #F, sString
Next
Close #F
strInfo$ = Chr(149) & " " _
& Mid$(File_Signal, InStrRev(File_Signal, "\") + 1, Len(File_Signal)) & vbCr
'### neu Ende
Open File_Test For Append As #F
sString = Join(.Transpose(.Transpose(tmpWS.UsedRange.Rows(lngMaxRow))), vbTab)
Print #F, sString
Close #F
strInfo$ = strInfo$ & Chr(149) & " " _
& Mid$(File_Test, InStrRev(File_Test, "\") + 1, Len(File_Test)) & vbCr '### geä _
ndert
' ab hier dann unverändert
lngMaxRow = lngMaxRow - 1
If lngMaxRow > 1 Then
Open File_ReTrain For Append As #F
nCount = .Max(2, lngMaxRow - 49)
For lngMaxRow = nCount To lngMaxRow
sString = Join(.Transpose(.Transpose(tmpWS.UsedRange.Rows(lngMaxRow))), _
vbTab)
Print #F, sString
Next lngMaxRow
Close #F
strInfo$ = strInfo$ & Chr(149) & " " & Mid$(File_ReTrain, InStrRev(File_ReTrain, "\" _
_
) + 1, Len(File_ReTrain)) & vbCr
End If
nCount = nCount - 1
If nCount > 1 Then
Open File_Train For Append As #F
For lngMaxRow = 2 To nCount
sString = Join(.Transpose(.Transpose(tmpWS.UsedRange.Rows(lngMaxRow))), _
vbTab)
Print #F, sString
Next lngMaxRow
Close #F
strInfo$ = strInfo$ & Chr(149) & " " & Mid$(File_Train, InStrRev(File_Train, "\") +  _
_
1, Len(File_Train)) & vbCr
End If
End With
End If
ErrorHandler:
If iCalc  0 Then oApp.Calculation = iCalc
oApp.Quit
Set oApp = Nothing
If Err.Number  0 Then
MsgBox Err.Description, vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
Else
MsgBox "Text- Files geschrieben!" & vbCr & vbCr & Left$(strInfo, Len(strInfo) - 1), _
vbInformation
End If
End Sub

Anzeige
;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige