Werte in .txt schreiben
Horst
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