AW: Felder aus verschiedenen Dateien auslesen?
24.04.2009 13:36:23
Tino
Hallo,
teste mal, Pfad musst Du im Code anpassen.
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 *****************************
strPfad = "J:\Aufträge\" 'abschließend auf \ achten
tempPfad = ShortPath(strPfad)
If tempPfad <> "" Then
Redim Preserve myAr(2, 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'!R7C8"
myAr(2, AA) = ExecuteExcel4Macro(strFormel)
AA = AA + 1
sFiles = Dir$() 'nächte Datei
Loop
If AA > 0 Then
Redim Preserve myAr(2, AA - 1) 'neu Dimensionieren
Set NeueTab = Worksheets.Add 'neue Tabelle erstellen
With NeueTab
.Range("A1") = "Dateiname"
.Range("B1") = "Zelle H6"
.Range("C1") = "Zelle H7"
.Range("A1:C1").Font.Bold = True
.Range("A2").Resize(Ubound(myAr, 2) + 1, 3) = Application.WorksheetFunction.Transpose(myAr)
End With
End If
End If
End Sub
Gruß Tino