AW: .xls-Dateien auslesen
08.02.2009 13:01:00
Horst
Hallo Sepp!
ich muss dich zum letzten VBA-Skript nochwas fragen: Es funktioniert jetzt soweit gut, allerdings gibt's Probleme beim Erstellen der .txt-Dateien. Ich bekomme die Meldung: "Fehler 438: Objekt unterstützt diese Eigenschaft oder Methode nicht." Ich denke, dass ich im VBA-Code noch was anpassen muss? strpath ist korrekt , Tabellenname ist Base, Datumsspalte FF, letzte auszulesende Spalte FG. Anbei der Code:
Option Explicit
Sub metaActualize()
Dim objWB As Workbook
Dim strPath 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
strPath = "C:\Dokumente und Einstellungen\User\Desktop\LOADMINM" 'Pfad anpassen
If Right(strPath, 1) "\" Then strPath = strPath & "\"
strFile = Dir(strPath & "*.xls")
Do While strFile ""
If isOpen(strFile) Then
Set objWB = Workbooks(strFile)
Else
Set objWB = Workbooks.Open(strPath & strFile)
End If
intIndex = intIndex + 1
Application.Calculate
objWB.Close True
strFile = Dir
Loop
'Textdateien
strSep = ";" 'Trennzeichenfür txt-Dateien
strFile = strPath & "Ergebnis.xls"
Set objWB = Workbooks.Open(strFile)
With objWB.Base 'hier Tabellenname - anpassen!
lngLastCol = .Columns("FG").Column 'letzte benutzte/auszulesende Spalte - anpassen!
lngRow = Application.Match(CLng(Date), Columns("FF"), 0)
arrVal = .Range(.Cells(1, 1), .Cells(lngRow, lngLastCol))
strTxtFile = strPath & "train.txt"
Open strTxtFile For Output As #1
For lngN = 1 To lngRow
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & 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 & arrVal(1, lngM) & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
strTxtFile = strPath & "test.txt"
Open strTxtFile For Output As #1
Print #1, strTmp
Close #1
End With
objWB.Close False
MsgBox "Es wurden " & CStr(intIndex) & " Dateien aktualisiert", vbInformation, "Hinweis"
ErrExit:
If Err.Number 0 Then MsgBox "Feher: " & Err.Number & vbLf & vbLf & _
Err.Description, vbExclamation, "Fehler"
GMS True
Set objWB = Nothing
End Sub
Private Function isOpen(FileName As String) As Boolean
Dim objWB As Workbook
For Each objWB In Application.Workbooks
If objWB.Name = FileName Then
isOpen = True
Exit For
End If
Next
End Function
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub