Performance Optimierung

Hallo Forums-Mitglieder,
mein aktuelles Problem ist, dass ich einen VBA Code habe der Funktioniert, aber leider viel zu langsam ist.
Mein Code:

Private Sub SearchColumns()
'Ich suche mir in Datei1, sowie in Datei2, die Columns in denen die unten aufgeführten Strings  _
stehen.

ActiveWorkbook.Worksheets("Datei1").Range("A2: AO2000").ClearContents
SearchCol(1) = "PLNNR"
SearchCol(2) = "PLNAL"
SearchCol(3) = "VORNR"
SearchCol(4) = "QPMK_REF"
SearchCol(5) = "MERKNR"
SearchCol(6) = "QPMK_ZAEHL"
SearchCol(7) = "VERWMERKM"
SearchCol(8) = "KURZTEXT"
SearchCol(9) = "MASSEINHSW"
SearchCol(10) = "STELLEN"
SearchCol(11) = "QMTB_WERKS"
SearchCol(12) = "PMETHODE"
SearchCol(13) = "STICHPRVER"
SearchCol(14) = "SOLLWERT"
SearchCol(15) = "TOLERANZUN"
SearchCol(16) = "TOLERANZUN_EX"
SearchCol(17) = "TOLERANZOB"
SearchCol(18) = "TOLERANZOB_EX"
SearchCol(19) = "AUSWMGWRK1"
SearchCol(20) = "AUSWMENGE1"
SearchCol(21) = "PROBENR"
SearchCol(22) = "STEUERKZ"
SearchCol(23) = "CODEGRQUAL"
SearchCol(24) = "CODEQUAL"
SearchCol(25) = "CODEGR9U"
SearchCol(26) = "CODE9U"
SearchCol(27) = "CODEVR9U"
SearchCol(28) = "CODEGR9O"
SearchCol(29) = "CODE9O"
SearchCol(30) = "CODEVR9O"
SearchCol(31) = "QDYNREG"
SearchCol(32) = "DYNMERK"
SearchCol(33) = "SPCKRIT"
SearchCol(34) = "FORMELSL"
SearchCol(35) = "FORMEL1"
SearchCol(36) = "FORMEL2"
SearchCol(37) = "QERGDATH"
SearchCol(38) = "PRUEFEINH"
SearchCol(39) = "DUMMY10"
SearchCol(40) = "DUMMY20"
SearchCol(41) = "DUMMY40"
SearchCol(42) = "GRENZEOB1"
SearchCol(43) = "GRENZEUN1"
SearchCol(44) = "FORMULA_IND"
SearchCol(45) = "INPPROC"
Dim i As Integer
For i = 1 To 45
FindCol(1, i) = ActiveWorkbook.Worksheets("Datei1").Range("A11:FB11").Find(what:=SearchCol(i),  _
lookat:=xlWhole).Column
FindCol(2, i) = ActiveWorkbook.Worksheets("Datei2").Range("A1:AT1").Find(what:=SearchCol(i),  _
lookat:=xlWhole).Column
Next i
End Sub

Private Sub CopyValues()
Dim lastItem As Long
Dim i As Long
Dim n As Integer
Dim k As Long
Dim SpeicherZelle As String
SpeicherZelle = "Start"
k = 2
lastItem = ActiveWorkbook.Worksheets("Datei1").Cells(Rows.Count, FindCol(1, 1)).End(xlUp).Row
Worksheets("Datei1").Activate
'Meine Such Spalte in der ich Prüfe ob Werte in den Zellen vorhanden sind.
Cells(12, FindCol(1, 5)).Offset(0, -2).Select
'Jetzt möchte ich für jede Row Checken ob der Wert gefüllt ist. Wenn dies der Fall ist, sollen  _
die Werte aus Datei1 in die gleichnamigen Columns aus Datei2 kopiert werden. Bei der zweiten For Schleife in der die Werte Kopiert werden brauch
das Makro etwa 50 sec, was bei einer Tabelle mit ~1000 Einträgen dann extrem lange dauert.
For i = 12 To lastItem
If Worksheets("Datei1").Cells(i, 48)  "" Then
For n = 1 To 45
Worksheets("Datei2").Cells(k, FindCol(2, n)).Value = Worksheets("Datei1").Cells(i, FindCol(1, n) _
).Value
Next n
k = k + 1
End If
ActiveCell.Offset(1, 0).Select
Next i
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub onStart() Application.Screenupdating = False Application.Calculation = xlCalculationManual Application.DisplaySatusbar = False End Sub Sub onEnd() Application.Screenupdating = True Application.Calculation = xlCalculationAutomatic Application.DisplaySatusbar = True End Sub

Private Sub CopyValues() Dim lastItem As Long Dim i As Long Dim n As Integer Dim k As Long Dim D1 As Variant, D2 As Variant lastItem = ActiveWorkbook.Worksheets("Datei1").Cells(Rows.Count, FindCol(1, 1)).End(xlUp).Row D1 = ActiveWorkbook.Worksheets("Datei1").Range("A12:FB" & lastItem).Value D2 = ActiveWorkbook.Worksheets("Datei2").Range("A2:AT" & lastItem - 10).Value For i = 1 To UBound(D1, 1) If D1(i, 48) "" Then k = k + 1 For n = 1 To 45 D2(k, FindCol(2, n)) = D1(i, FindCol(1, n)) Next n End If Next i ActiveWorkbook.Worksheets("Datei2").Range("A2").Resize(UBound(D2, 1), UBound(D2, 2)) = D2 End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread