hier meine Version.
24.09.2009 08:57:55
Tino
Hallo,
kannst ja mal testen.
Sub LeseDaten()
Dim strFile As String, strPfad As String, strWerkzeug As String
Dim oWB As Workbook, rZelle As Range
Dim meAr(), A As Long
Dim NeuTab As Worksheet
Dim iCalc As Integer
strWerkzeug = "WZK-91" 'Suchwerkzeug
strPfad = "C:\WERKZEUGLISTEN\" 'Pfad am ende auf \ achten
strFile = Dir(strPfad & "*.xls")
If strFile <> "" Then
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
Do While strFile <> ""
On Error Resume Next
Set oWB = Workbooks.Open(strPfad & strFile, True, True)
Set rZelle = oWB.Sheets("WZK").Columns(3).Find(What:=strWerkzeug, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rZelle Is Nothing And Err.Number = 0 Then
A = A + 1
Redim Preserve meAr(1 To 2, 1 To A)
meAr(1, A) = strFile
meAr(2, A) = rZelle.Address(False, False)
End If
oWB.Close False
strFile = Dir()
On Error GoTo 0: Err.Clear
Loop
If A > 0 Then
On Error Resume Next
Set NeuTab = Sheets("ÜBERSICHT")
On Error GoTo 0
If NeuTab Is Nothing Then
Set NeuTab = Worksheets.Add 'neue Tabelle erstellen
NeuTab.Name = "ÜBERSICHT" 'name vergeben
Else
NeuTab.Range("A:B").Value = ""
End If
NeuTab.Range("A1") = "Dateiname"
NeuTab.Range("B1") = "In Zelle"
NeuTab.Range("A1:B1").Font.Bold = True
NeuTab.Range("A2").Resize(Ubound(meAr, 2), Ubound(meAr)) = .Transpose(meAr)
End If
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
End If
End Sub
Gruß Tino