hat irgendjemand eine Ahnung, was bei folgender VBA-Prozedur zu einem "Fehler 13: Typen unverträglich" führen könnte? In 90 % der Fälle funktioniert der Code problemlos, selten bricht er jedoch mit einer Fehlermeldung ab, erstellt dann die Dateien "retrain.txt" und "text.txt", verweigert allerdings die Erstellung von "train.txt".
Wenn jemanden etwas auffallen würde, wäre super!
Gruß, Horst
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 = True '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 - 69)
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