Dateiordner mit 350 Excelsheets auslesen

Gerhard · 1970-01-01T00:00:00+00:00

Guten Morgen da draussen Wurde hier mit einem Prob beauftragt und weiss absolut nicht wie ich das lösen kann Habe einen Ordner Namens Werkzeuglisten. In diesem sind ca. 350 Excellisten. Ich muss nun in diesen 350 Excellisten suchen wo sich das Werkzeug mit der Bezeichnung "WZK-91" befindet. Klar könnt ich das alles von Hand suchen, aber das muss doch auch über n Makro funzen, oder? So in etwa: Öffne Pfad C:\WERKZEUGLISTEN Öffne erste Datei (haben alle versch. Dateinamen!!!) und schaue in Spalte C nach WZK-91 Wenn gefunden, übertrage Dateinamen in in neues Sheet namens "ÜBERSICHT" Schliesse Datei und öffne nächste usw. Kann mir dabei jemand helfen oder hat vllt. schon ne Lösung? Wäre super, danke für die Hilfe schon mal Greetz Gerhard

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

Hi.
Hier noch meine Version:

Sub readWkz(Optional suchStr)
Dim quellWbk As Workbook
Dim myFile As String
Dim foundFiles() As String
Const myPath = "c:\Werkzeuglisten\"
Const suchDatei = "*.xls"
Const searchSheet = "WKZ"
Const searchCol = 3
' Suchstring kann übergeben werden, wenn das nicht passiert ist dann wird
' dieser abgefragt
If IsMissing(suchStr) Then
suchStr = Application.InputBox("Suchbegriff eingeben", "Suchbegriff")
' Abbrechen betätigt oder nichts eingeben
If suchStr = "" Then Exit Sub
End If
Application.ScreenUpdating = False
' Zielarray vordimensionieren
ReDim foundFiles(0 To 0)
myFile = Dir(myPath & suchDatei)
While myFile  ""
With Workbooks.Open(myPath & myFile, False, True)
' Fehlerbehandlung aus, falls Sheet nicht existiert
On Error Resume Next
If Not .Sheets("WKZ").Columns(searchCol).Find(suchStr, , xlValues) Is Nothing Then
' An diese Stelle gelangt es auch bei einem Fehler, daher noch Fehlerabfrage
If Err.Number = 0 Then
' Array mit den Dateinamen dimensionieren
If UBound(foundFiles) = 0 Then
ReDim foundFiles(1 To 1)
Else
ReDim Preserve foundFiles(1 To UBound(foundFiles) + 1)
End If
foundFiles(UBound(foundFiles)) = myFile
End If
End If
On Error GoTo 0
.Close False
End With
myFile = Dir
Wend
' Wenn was gefunden wurde
If UBound(foundFiles) > 0 Then
Workbooks.Add.Sheets(1).Cells(1, 1).Resize(UBound(foundFiles)).Value _
= Application.Transpose(foundFiles)
Else
MsgBox ("Nichts gefunden")
End If
Application.ScreenUpdating = True
End Sub

Die Arbeitsmappen werden ohne Aktualisierung der Verknüpfungen geladen.
Gruss, Jogy

Dateiordner mit 350 Excelsheets auslesen

Forumthread: Dateiordner mit 350 Excelsheets auslesen

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Dateiordner mit 350 Excelsheets auslesen

Forumthread: Dateiordner mit 350 Excelsheets auslesen

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread