Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1492to1496
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Performancesteigerung Kopieren

Performancesteigerung Kopieren
10.05.2016 12:19:48
dani_boy
Hallo Leute,
ich würde gerne die Performance meiner Kopiervorgänge steigern.
Kurz zur Situation:
Die Übersichtsdatei läd Daten aus verschiedenen anderen Excel-Dateien zusammen. Dabei werden die einzelnen Excel-Dateien jedoch nicht geöffnent. Wenn ich nun den Code ausführen dauert das "zusammen kopieren" der einzelnen Dateien ca. 80 Sekunden.
Das ist immernoch maßgeblich schneller als händische kopieren, trotzdem würde mich interessieren ob es Möglichkeiten gibt die Performance zu steigern.
Über diese Funktionen werden die Daten aus den einzelenen Regionen in die Übersichtsdatei gealden:

Private Function GetValue(pfad, datei, blatt, zelle)
'** Daten aus geschlossener Arbeitsmappe auslesen
'*** Dimensionierung der Variablen
Dim arg As String
'Sicherstellen, dass das 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 BaWü_auslesen()
'** Dimensionierung der Variablen
Dim pfad As String, datei As String, blatt As String, bereich As Range, zelle As Object
'** Angaben zur auszulesenden Zelle
pfad = ThisWorkbook.Path
datei = "Bawü - Editable.xlsx"
blatt = "Projektliste"
Set bereich = Range("B6:J195")
'** Bereich auslesen
For Each zelle In bereich
'** Zellen umwandeln
zelle = zelle.Address(False, False)
'** Eintragen in Bereich
ActiveWorkbook.Sheets("BaWü").Cells(zelle.Row, zelle.Column).Value = GetValue(pfad, datei,  _
blatt, zelle)
Application.CutCopyMode = False
Next zelle
End Sub

Der Vorgang wird für smätliche Regionen wiederholt:

Sub Test()
BaWü_auslesen
Bayern_auslesen
Mitte_auslesen
Nord_auslesen
Ost_auslesen
West_auslesen
End Sub

Falls jemand eine Idee wie man das schlanker macht und so die Perfomrance steigert, immer raus damit :)
PS: Falls jemand noch eine Idee hat wie man nach Beendigung des Kopiervorgangs den Zwischenspeicher freigibt würde mir das auch helfen.
Grüße
Daniel

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Performancesteigerung Kopieren
10.05.2016 12:23:14
Michael
Hallo Daniel
bzgl. Zwischenspreicher am Ende des Codes folgendes einsetzen:
Application.CutCopyMode = False
Gruß
Michael

AW: Performancesteigerung Kopieren
10.05.2016 12:41:50
Nepumuk
Hallo,
öffne die Dateien richtig, dann kannst du den Bereich in einem Rutsch kopieren. Deine Methode öffnet die Datei im Hintergrund für jede Zelle einmal.
Gruß
Nepumuk

AW: Performancesteigerung Kopieren
10.05.2016 14:29:47
Michael
Hallo Daniel,
versuche mal diesen Code (muss du natürlich noch ein wenig anpassen).
Ist jetzt auch nur für die Datei BaWü.
Sub BaWÜ_auslesen_neu()
Dim sFile As String, sPath As String
Dim WB1 As Workbook, WB2 As Workbook
Dim WS1 As Worksheet, WS2 As Worksheet
Const Pfad = "Hier deinen Pfad eintragen" ' zum Beispiel D:\Ort\Bawü\
Const Datei = "Bawü - Editable.xlsx" 'hier der Name der auszulesenden Datei
Application.ScreenUpdating = False
' Abschaltung der Zwischenablage
Application.DisplayAlerts = False
Set WB1 = ThisWorkbook 'diese Datei
Set WB2 = Workbooks.Open(Pfad & Datei) '
Set WS1 = WB1.Worksheets("Tabellenname") ' von der Übersichtsdatei
Set WS2 = WB2.Worksheets("Projektliste") ' Tabellenname der auszulesenden Datei
'WS1.Range("B6:J195").Clear ' falls die vorherigen Daten gelöscht werden sollen
WS2.Range("B6:J195").Copy WS1.Range("Zelle aussuchen")
Windows("Bawü - Editable.xlsx").Close SaveChanges:=False ' die auszulesende Datei wird  _
geschlossen
Range("A1").Select
' Einschaltung der Zwischenablage
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Gruß
Michael

Anzeige
AW: Performancesteigerung Kopieren
10.05.2016 16:14:36
dani_boy
Hi Michael Nepmunk,
danke für eure Antworten. Ich bin gerade dabei Michaels Code umzusetzen.
Da es sich bei mir um einen Ordner handelt der auch mal verschoben wird wollte ich folgedes versuchen. Die Übersichts Datei ist immer im selben Ordner wie die Regions Tabellen.
Const Pfad = ThisWorkbook.Path ' zum Beispiel D:\Ort\Bawü\
Daraufhin erscheint eine Fehlermeldung die sagt das es sich um keine Konstante handelt. Wenn ich das "Const" lösche läuft der Debugger zwar durch aber er hängt in Zeile
   Set WB2 = Workbooks.Open(Pfad & Datei) '
mit dem Fehlercode 1004. Das heißt wohl das die Datei nicht gefunden wird.
Hat einer spontan eine Idee?
Ich werde morgen weiter probieren.
Grüße und Danke
Daniel

Anzeige
AW: Performancesteigerung Kopieren
10.05.2016 16:30:23
Nepumuk
Hallo,
teste mal:
Private Sub BaWü_auslesen()
    
    '** Dimensionierung der Variable
    Dim objWorkbook As Workbook
    
    '** Excel vorbereiten
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    '** Mappe öffnen
    Set objWorkbook = Workbooks.Open(Filename:=ThisWorkbook.Path & _
        "Bawü - Editable.xlsx", UpdateLinks:=0, ReadOnly:=True)
    
    '** Bereich kopieren
    Call objWorkbook.Worksheets("Projektliste").Range("B6:J195").Copy( _
        Destination:=ThisWorkbook.Worksheets("BaWü").Cells(6, 2))
    
    '** Mappe schließen
    Call objWorkbook.Close(SaveChanges:=False)
    
    '** Objekt zurücksetzen
    Set objWorkbook = Nothing
    
    '** Excel zurücksetzen
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Gruß
Nepumuk

Anzeige
AW: Performancesteigerung Kopieren
10.05.2016 17:07:43
Nepumuk
Nochmal hallo,
da ist noch ein Fehler drin:
    Set objWorkbook = Workbooks.Open(Filename:=ThisWorkbook.Path & _
"\Bawü - Editable.xlsx", UpdateLinks:=0, ReadOnly:=True)

Gruß
Nepumuk

AW: Performancesteigerung Kopieren
12.05.2016 11:55:17
dani_boy
Hi Nepumuk,
hat super geklappt Danke.
Grüße
Daniel

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige