Geschwindigkeitsprobleme
25.09.2006 13:24:43
Peter
Nachfolgender Code beschert mir Geschwindigkeitsprobleme. Ich importiere ca. 150 Zeilen aus anderen geschlossenen Dateien. Das Prozedere dauert etwa 3-4 Minuten.
Sieht jemand einen Anhaltspunkt, wie optimiert werden könnte?
Danke für eine Rückmeldung.
Peter
Option Explicit
Sub DatenEintragen()
ThisWorkbook.Activate
GetMoreSpeed
On Error GoTo ErrExit
Dim Bereich As Range, Feld As Range
Dim QArea As Range, QCell As Range
Dim p$, f$, r$, n%, s$, m%, zeile$
Dim Anzahl$
s = "Export"
n = Cells(65536, 1).End(xlUp).Row 'ermittelt letzten Eintrag in Spalte A (Pfad)
m = Cells(2, 256).End(xlToLeft).Column 'ermittelt letzten Eintrag in Zeile 2 (Ref zu Import)
r = Range("E4") 'legt ersten Eintrag in Zeile 3 fest (Ref zu Import)
Set Bereich = Range("A4:A" & n) 'Bereich = alle Zellen mit Pfadangabe
Set QArea = Range(Cells(2, 5), Cells(2, m)) 'Bereich K2 : ?2 = alle Zellen mit Ref Angabe zu Import
Anzahl = 0
For Each Feld In Bereich
p = Feld.Value
f = Feld.Offset(0, 1)
zeile = Feld.Offset(0, 2)
Debug.Print zeile
For Each QCell In QArea
r = QCell.Value & zeile
Debug.Print r
Cells(Feld.Row, QCell.Column) = getvalue(p, f, s, r)
Application.StatusBar = "Daten werden importiert aus " & p & f & " - Eintrag in Zeile " & Anzahl + 5
Next
Anzahl = Anzahl + 1
Next
Application.StatusBar = "Import abgeschlossen"
ErrExit:
GetMoreSpeed 0
End Sub
Private Function getvalue(path, File, sheet, ref)
'retrieves a value from a closed workbook
Dim arg As String
'make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & File) = "" Then
getvalue = "File not found"
Exit Function
End If
'create the argument
arg = "'" & path & "[" & File & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
''Debug.Print arg
'execute an xlm macro
getvalue = ExecuteExcel4Macro(arg)
End Function