Autofilter
Horst
Hallo Tino!
Der folgende Code filtert ein Arbeitsblatt nach bestimmten Kriterien (per Autofilter) und speichert das Ergebnis als .txt-Datei ab, was an und für sich problemlos funktioniert. Allerdings werden in der .txt-Datei die Datumsformate nicht richtig übernommen, Ländereinstellung ist Deutsch (mit Punkt als Dezimaltrennzeichen); Beispiel:
2/22/1991
2/27/1991
03.04.1991
3/22/1991
3/28/1991
06.05.1991
6/25/1991
07.01.1991
7/29/1991
8/20/1991
8/28/1991
09.05.1991
Muss an der Zeile:
.UsedRange.AutoFilter Field:=7, Criteria1:=" etwas verändert werden?
Anbei der vollständige Code:
Option Explicit
Sub Schreibe_TxT()
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 & "database.xls" 'evtl. Pfad anpassen
File_Test = sPath & "Test.txt" 'evtl. Pfad anpassen
File_Train = sPath & "Train.txt" 'evtl. Pfad anpassen
File_ReTrain = sPath & "ReTrain.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
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:=8, Criteria1:="1"
.UsedRange.AutoFilter Field:=7, 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