Schleife / Code verschnellern?
10.05.2019 09:31:00
Tim
der folgende Code funktioniert einwandfrei. Er ist mir persöhnlich nur zu langsam.
Meine Frage: Gibt es eine Möglichkeit ihn zu beschleunigen?
Aufbau meiner Datei:
Ich habe in der Linken Spalte einen Pfad stehen der sich in jeder Zeile ändert, manuell angepasst wird.
Dieser Pfad wird über STRG + Shift aus einem Laufwerk kopiert. (ca. 30-40 Pfäde)
Die werden dann in den Dateipfad und den Dateinamen aufgesplittet.
in den Zeilen über den Überschriften gibt es die Zeile: Tabelle und Zeile
Diese Werte ändern sich in jeder Spalte.
Also im Grunde sucht sich das Makro über eine Schleife die Daten aus mehreren Geschlossenen Arbeitsmappe zusammen wobei ich die Bereiche variable in Excel angebe.
Die Bereiche die ich oben in den ersten Zellen angebe sind in jeder Arbeitsmappe gleich.
Code:
Sub Zelle_auslesen_lang()
'** Dimensionierung der Variablen
'Quelle https://www.excel-inside.de/vba-loesungen/datei/947-daten-aus-geschlossener- _
arbeitsmappe-auslesen
'abgeändert von Tim.Ertl
Dim pfad As String, datei As String, blatt As String, zelle As String, bezug As String
Dim i As Long
Dim r As Long
Dim a As Long
Call ClearCells_lang
r = Selection.Row
a = WorksheetFunction.CountA(Worksheets("Analyse").Range("1:1")) - 2
Worksheets("Analyse").Cells(r, 4).Select
For i = 0 To a
ActiveCell.Offset(0, 1).Range("A1").Select
'** Angaben zur auszulesenden Zelle
pfad = Worksheets("Analyse").Cells(r, 2).Value
datei = Worksheets("Analyse").Cells(r, 3).Value
blatt = Worksheets("Analyse").Cells(1, 5 + i).Value
bezug = Worksheets("Analyse").Cells(2, 5 + i).Value
If blatt = "leer" Then GoTo Sprung
'** Eintragen in Zelle
ActiveCell.Value = GetValue(pfad, datei, blatt, bezug)
Sprung:
Next
End Sub
Public Function GetValue(pfad, datei, blatt, zelle)
'** Daten aus geschlossener Arbeitsmappe auslesen
'Quelle https://www.excel-inside.de/vba-loesungen/datei/947-daten-aus-geschlossener- _
arbeitsmappe-auslesen
'*** Dimensionierung der Variablen
Dim arg As String
'Sicherstellen, dass die Datei vorhanden ist
If Right(pfad, 1) "\" Then pfad = pfad & "\"
If Dir(pfad & datei) = "" Then
GetValue = "datei Not Found"
Exit Function
End If
'** Das Argument erstellen
arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(zelle).Range("A1").Address(, , _
xlR1C1)
'** Auslesen über Excel4Macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub ClearCells_lang()
Dim r As Long
Dim a As Long
Dim zelle As Range
r = Selection.Row
a = WorksheetFunction.CountA(Worksheets("Analyse").Range("1:1")) + 3
For Each zelle In Sheets("Analyse").Range(Cells(r, 5), Cells(r, a))
If zelle.HasFormula = True Then Else zelle.ClearContents
Next zelle
End Sub
Mit freundlichen Grüßen
Tim Ertl