Thema Datum  Von Nutzer Rating
Antwort
Rot Per Makro mehrere Tabellen öffnen
 09.12.2019 16:07:32 gast909090
Solved
09.12.2019 17:01:40 UweD
Solved
09.12.2019 18:03:50 gast909090
Solved
09.12.2019 18:05:34 Gast58613
Solved
10.12.2019 14:02:38 UweD
Solved
10.12.2019 14:58:42 gast909090
Solved

Ansicht des Beitrags:
Von:
gast909090		 Datum:
09.12.2019 16:07:32		 Views:
1649		 Rating:
     
Antwort:
 Nein
Thema:
Per Makro mehrere Tabellen öffnen

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.

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
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.

A B C D E F G H I J K
  2019/40     BRE1       D   BREMEN / OSTERHOLZ - SCHARMBECK
  2019/40     HAM1       D   WENZENDORF
  2019/40     HAM2       D   WENZENDORF
  2019/40     LEV1       D   LEVERKUSEN
  2019/40     LEV2       D   LEVERKUSEN
  2019/40     MUN1       D   MÜNCHEN
  2019/40     MUN2       D   MÜNCHEN
  2019/40     MUN3       D   MÜNCHEN
  2019/41     BRE1       D   BREMEN / OSTERHOLZ - SCHARMBECK
  2019/41     HAM1       D   WENZENDORF
  2019/41     HAM2       D   WENZENDORF
  2019/41     LEV1       D   LEVERKUSEN
  2019/41     LEV2       D   LEVERKUSEN
  2019/41     MUN1       D   MÜNCHEN
  2019/41     MUN2       D   MÜNCHEN
  2019/41     MUN3       D   MÜNCHEN
  2019/41     MUN4       D   MÜNCHEN
  2019/41     MUN5       D   MÜNCHEN

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Per Makro mehrere Tabellen öffnen
 09.12.2019 16:07:32 gast909090
Solved
09.12.2019 17:01:40 UweD
Solved
09.12.2019 18:03:50 gast909090
Solved
09.12.2019 18:05:34 Gast58613
Solved
10.12.2019 14:02:38 UweD
Solved
10.12.2019 14:58:42 gast909090
Solved