Hallo Zusammen,

ich hoffe hier kann mir jemand weiterhelfen. Ich habe seit geraumer Zeit ein Problem, dass ich ständig in sehr vielen Tabellen nach Werten suchen muss und daher habe ich mir ein Makro gebastelt, welches mir den Arbeitsaufwand erleichtern soll.

In meinem Arbeitsblatt namens „Daten“ wird für jede einzelne Zeile eine Datei aufgerufen (den Pfad berechnet das Makro über Zellen B und I in „Daten“), sucht dort nach der Referenz (Spalte E in „Daten“) und schreibt alle jeweiligen Werte nebeneinander, ab Spalte AC. Dies funktioniert soweit auch gut, nur dauert das etwas länger, da ich manchmal um die 2000 Zeilen habe die das Makro abarbeiten muss. Ich glaube, das hängt damit zusammen, da ich es nicht effizient genug gestaltet habe. Das Makro öffnet zuerst die Datei, sucht nach den Werten und schließt dann wieder die Datei. Meine Frage daher, kann man die Rechengeschwindigkeit des Makros irgendwie erhöhen? Das Makro müsste nicht nach jeder Zeile die geöffnete Arbeitsmappe wieder schließen, da sich mehrere Referenzen in derselben Datei befinden können.

Die Werte für das Arbeitsblatt „Daten“ sind ein Auszug aus meinem Hauptprogramm, welche ich auch per Makro einlese und sortiere. Leider wird das Hauptprogramm von Menschenhand erstellt/bedient und daher musste ich mehrere Abfragen einbauen um überhaupt den Pfad zu den einzelnen Daten erstellen zu können. Ansonsten wäre mir viel Code erspart geblieben :-(.

Auf einem der Serverlaufwerke liegen die einzelnen Tabellen und sind immer pro Land und wochenweise abgespeichert. Manchmal bekomme ich eine abgeänderte Bestellung vom Kunden, welche auf Ä1, oder Ä2 endet. Daher muss diese Datei zum Schreiben in „Daten“ verwendet werden und nicht die normale Datei.

Sub test()

Dim wbi As Workbook, wb2 As Workbook, wsi As Worksheet, ws2 As Worksheet
Dim lngCount As Long
Dim j As Integer

Set fso = CreateObject("Scripting.FileSystemObject")
Dim files As String
Set ws2 = ThisWorkbook.Sheets("Daten")

Dim myRng As Range
Dim iRow As Integer

    wsLR = ws2.Cells(Rows.Count, 2).End(xlUp).Row
    For iRow = 1 To wsLR
        Dim pfad As String
        Dim arrFile As Variant
        Dim finalrow, x, y As Integer
        
        
        arrFile = Split(Cells(iRow, 2).Value, "/")
 
        If (Cells(iRow, 9).Value <> "A" And _
            Cells(iRow, 9).Value <> "B" And _
            Cells(iRow, 9).Value <> "D" And _
            Cells(iRow, 9).Value <> "FIN" And _
            Cells(iRow, 9).Value <> "H" And _
            Cells(iRow, 9).Value <> "IRL" And _
            Cells(iRow, 9).Value <> "S" And _
            Cells(iRow, 9).Value <> "SLO" And _
            Cells(iRow, 9).Value <> "SRB" And _
            Cells(iRow, 9).Value <> "US") Then
            
            
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*" & Cells(iRow, 9) & "*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\ & arrFile(0) & "\KW " & arrFile(1) & "\*" & Cells(iRow, 9) & "*.xlsx"
            End If
             
                
        ElseIf Cells(iRow, 9).Value = "A" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*AT*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*AT*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "B" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*BE*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*BE*.xlsx"
            End If
        ElseIf Cells(iRow, 9) = "D" Then
            pfad = "S:\Kunden\ & arrFile(0) & "\KW " & arrFile(1) & "\*DE*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*DE*.xlsx"
            End If
        ElseIf Cells(iRow, 9) = "FIN" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*FI*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*FI*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "H" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*HU*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*HU*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "IRL" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*IE*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*IE*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "IRL" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*NI*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*NI*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "S" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*SE*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*SE*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "SLO" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*SI*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*SI*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "SRB" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) + 1 & "\*RS*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) + 1 & "\*RS*.xlsx"
            End If
        ElseIf Cells(iRow, 9).Value = "US" Then
            pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*LX*Ä*.xlsx"
            If Dir(pfad, vbNormal) <> "" Then
             pfad = pfad
            Else
             pfad = "S:\Kunden\" & arrFile(0) & "\KW " & arrFile(1) & "\*LX*.xlsx"
            End If
        
        End If
        
        Set wbi = Workbooks.Open(pfad, IgnoreReadOnlyRecommended:=True)
        Set wsi = wbi.Worksheets("Bestellmengen")
        y = 1
        finalrow = wsi.Cells(Rows.Count, 1).End(xlUp).Row
            For x = 1 To finalrow
            If (wsi.Cells(x, 58) = "EP" Or wsi.Cells(x, 58) = "CHEP") Then
                If wsi.Cells(x, 10) = ws2.Cells(iRow, 5) Then
                    ws2.Cells(iRow, 28 + y) = wsi.Cells(x, "AZ")
                    y = y + 1
                End If
            ElseIf wsi.Cells(x, 58) = "DD" Then
             If wsi.Cells(x, 10) = ws2.Cells(iRow, 5) Then
                    ws2.Cells(iRow, 28 + y) = wsi.Cells(x, "AZ") / 2
                    y = y + 1
                End If
            End If
            Next x
        wbi.Close False
        
        
    Next iRow


End Sub

Mein Tabelle "Daten" sieht ungefähr so aus, nur sind in der originalen mehrer Einträge sowie Länder enthalten.