ich habe den Skript um 3 abzufragende Felder erweitert. Leider erhalte ich jetzt in der
unteren Zeile eine Fehlermeldung. Kann mir jemand sagen warum?
Private Declare Function GetShortPathNameA Lib "kernel32" ( _
ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
Public Function ShortPath(ByRef Path As String) As String
Dim n As Long
ShortPath = Space$(256)
n = GetShortPathNameA(Path, ShortPath, 255)
ShortPath = Left$(ShortPath, n)
End Function
Sub TestLeseDaten()
Dim sFiles As String
Dim strPfad As String, tempPfad As String
Dim strFormel As String
Dim myAr()
Dim AA As Long
Dim NeueTab As Worksheet
'hier den Pfad angeben *****************************
'liest die Daten aus den Einzelnen Dateien aus
strPfad = "H:\Stanzen\" 'abschließend auf \ achten
tempPfad = ShortPath(strPfad)
If tempPfad "" Then
ReDim Preserve myAr(5, 10000) 'Area groß genug für 10001 Dateien
sFiles = Dir$(tempPfad & "*.xls")
Do While sFiles ""
'Dateiname
myAr(0, AA) = sFiles
'Formel für Zelle erstellen, Tabellennamen anpassen (Tabelle1)
strFormel = "'" & strPfad & "[" & sFiles & "]Tabelle1'!R6C8"
myAr(1, AA) = ExecuteExcel4Macro(strFormel)
'Formel für Zelle erstellen, Tabellennamen anpassen (Tabelle1)
strFormel = "'" & strPfad & "[" & sFiles & "]Tabelle1'!R6C9"
myAr(2, AA) = ExecuteExcel4Macro(strFormel)
'Formel für Zelle erstellen, Tabellennamen anpassen (Tabelle1)
strFormel = "'" & strPfad & "[" & sFiles & "]Tabelle1'!R2C3"
myAr(3, AA) = ExecuteExcel4Macro(strFormel)
'Formel für Zelle erstellen, Tabellennamen anpassen (Tabelle1)
strFormel = "'" & strPfad & "[" & sFiles & "]Tabelle1'!R3C9"
myAr(4, AA) = ExecuteExcel4Macro(strFormel)
'Formel für Zelle erstellen, Tabellennamen anpassen (Tabelle1)
strFormel = "'" & strPfad & "[" & sFiles & "]Tabelle1'!R14C9"
myAr(5, AA) = ExecuteExcel4Macro(strFormel)
AA = AA + 1
sFiles = Dir$() 'nächte Datei
GoTo sprungmarke:
Loop
sprungmarke:
If AA > 0 Then
ReDim Preserve myAr(5, AA - 1) 'neu Dimensionieren
Set NeueTab = Worksheets.Add 'neue Tabelle erstellen
With NeueTab
.Range("A1") = "Dateiname"
.Range("B1") = "Zelle H6"
.Range("C1") = "Zelle I7"
.Range("D1") = "Zelle C2"
.Range("E1") = "Zelle I3"
.Range("F1") = "Zelle I14"
.Range("A1:F1").Font.Bold = True
' Hier kommt die Fehlermeldung: Index außerhalb des gültigen Bereichs!
.Range("A2").Resize(UBound(myAr, 5) + 1, 3) = Application.WorksheetFunction.Transpose(myAr)
End With
End If
End If
End Sub