Ich würde gern die Funktionalität folgender zwei VBA-Proezuduren in einem Makro verbinden.
Das erste Makro filtert mittels Autofilter bestimmte Werte, das zweite wandelt in Abhängigkeit vom Systemdatum die .xls in Textdateien um. Es soll nun ein Makro entstehen, dass zunächst die gewünschten Zeilen mittels Autofilter selektiert und danach die gewünschten .txt-Dateien generiert.
Wie gehe ich am besten vor?
Sub Selection_one()
Dim wbText As Workbook, wbAktiv As Workbook, vFilename
Set wbAktiv = ActiveWorkbook
Cells.AutoFilter Field:=131, Criteria1:="1"
Range("A1:DY65536").Copy 'es werden keine verknüpfungen kopiert
Set wbText = Workbooks.Add(Template:=xlWBATWorksheet)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Dokumente und Einstellungen\User\Desktop\system\update\FilteredBase_one.xls", _
FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End Sub
Sub PatternFiltering_one()
Dim objWb As Workbook
Dim strPath1 As String, strFile As String, strTxtFile As String, strTmp As String, strSep _
As String
Dim intIndex As Integer, lngRow As Long, lngLastCol As Long, lngN As Long, lngM As Long
Dim arrVal As Variant
On Error GoTo ErrExit
GMS
strPath1 = "C:\Dokumente und Einstellungen\User\Desktop\system\update" 'Pfad
If Right(strPath1, 1) "\" Then strPath1 = strPath1 & "\"
strFile = Dir(strPath1 & "*.xls")
Do While strFile ""
If isOpen(strFile) Then
Set objWb = Workbooks(strFile)
Else
Set objWb = Workbooks.Open(strPath1 & strFile)
End If
intIndex = intIndex + 1
Application.Calculate
objWb.Close True
strFile = Dir
Loop
'Textdateien
strSep = vbTab 'Trennzeichen für txt-Dateien
strFile = strPath1 & "database.xls"
Set objWb = Workbooks.Open(strFile)
With objWb.Sheets("results") 'Tabellenname!
lngLastCol = .Columns("DY").Column 'letzte auszulesende Spalte
lngRow = Application.Match(CLng(Date), .Columns("DY"))
arrVal = .Range(.Cells(1, 1), .Cells(lngRow, lngLastCol))
strTxtFile = strPath1 & "train_one.txt"
Open strTxtFile For Output As #1
For lngN = 1 To lngRow
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & Replace(arrVal(lngN, lngM), ",", ".") & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
Print #1, strTmp
Next
Close #1
strTxtFile = strPath1 & "retrain_one.txt"
Open strTxtFile For Output As #1
For lngN = 4000 To lngRow
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & Replace(arrVal(lngN, lngM), ",", ".") & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
Print #1, strTmp
Next
Close #1
arrVal = .Range(.Cells(lngRow + 1, 1), .Cells(lngRow + 1, lngLastCol))
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & Replace(arrVal(1, lngM), ",", ".") & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
strTxtFile = strPath1 & "test_one.txt"
Open strTxtFile For Output As #1
Print #1, strTmp
Close #1
End With
objWb.Close False
ErrExit:
If Err.Number 0 Then
End If
GMS True
Set objWb = Nothing
End Sub
Besten Dank vorab!
Horst