Makro braut sehr lange

Hallo,
ich habe 2 Datenbanken mit sehr unterschiedlichen befüll Status, und möchte in die neuere den bereits erfassten Inhalt der älteren übernehmen, und zeitgleich sichtbar machen welche Zeilen der älteren nicht in der neueren sind.
zudem sind in der älteren oft falsche voran- und nachstehende Leerzeichen :-(
Dazu habe ich folgendes simples Makro gebastelt, nur leider benötigt es sehr sehr ... lange und während das Makro durchläuft reagiert Excel nicht mehr.
Meine Frage, wie kann ich, falls möglich, das Makro beschleunigen?

Sub db_abgleich()
Dim A_ende As Long
Dim B_ende As Long
Dim i As Long
Dim j As Long
A_ende = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
B_ende = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 4 To A_ende ' ~70000
For j = 2 To B_ende ' ~90000
If Trim(Sheets(1).Range("C" & i).Value) = Trim(Sheets(2).Range("A" & j).Value) Then
If Trim(Sheets(1).Range("E" & i).Value) = Trim(Sheets(2).Range("D" & j).Value) Then
Sheets(1).Range("B" & i).Value = Trim(Sheets(2).Range("B" & j).Value)
Sheets(1).Range("D" & i).Value = Trim(Sheets(2).Range("C" & j).Value)
Sheets(1).Range("G" & i).Value = Trim(Sheets(2).Range("G" & j).Value)
Sheets(1).Range("H" & i).Value = Trim(Sheets(2).Range("H" & j).Value)
Sheets(1).Range("K" & i).Value = Trim(Sheets(2).Range("I" & j).Value)
Sheets(1).Range("L" & i).Value = Trim(Sheets(2).Range("J" & j).Value)
Sheets(1).Range("M" & i).Value = Trim(Sheets(2).Range("K" & j).Value)
Sheets(1).Range("N" & i).Value = Trim(Sheets(2).Range("L" & j).Value)
Sheets(2).Range("A" & j & ":L" & j).ClearContents
End If
End If
Next j
Next i
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub db_abgleich() Dim vntA, vntB Dim A_ende As Long Dim B_ende As Long Dim i As Long Dim j As Long Dim k As Long A_ende = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row B_ende = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row vntA = Sheets(1).UsedRange vntB = Sheets(2).UsedRange For i = 4 To UBound(vntA) ' ~70000 For j = 2 To UBound(vntB) ' ~90000 If Trim(vntA(i, 3)) = Trim(vntB(j, 1)) Then If Trim(vntA(i, 5)) = Trim(vntB(j, 4)) Then vntA(i, 2) = Trim(vntB(j, 2)) vntA(i, 4) = Trim(vntB(j, 3)) vntA(i, 7) = Trim(vntB(j, 7)) vntA(i, 8) = Trim(vntB(j, 8)) vntA(i, 11) = Trim(vntB(j, 9)) vntA(i, 12) = Trim(vntB(j, 10)) vntA(i, 13) = Trim(vntB(j, 11)) vntA(i, 14) = Trim(vntB(j, 12)) For k = 1 To UBound(vntB, 2) vntB(j, k) = "" Next k End If End If Next j Next i Sheets(1).UsedRange = vntA Sheets(2).UsedRange = vntB End Sub

HI
mal so als Gedankenansatz, den du zunächst mal von Hand ausprobieren solltest.
wenn er klappt, kannst du ja diesen in VBA umsetzen:
1. füge in beiden Tabellen eine neue leere Spalte am Anfang ein (Spalte A)
2. füge in die Spalte A eine Formel ein, in welcher du die beiden Vergleichsbegriffe (C+E in Sheet 1, A+D in Sheet 2) zu einem Wort zusammensetzt, über Glätten() kannst du die Leerzeichen entfernen:
=Glätten(C4)&Glätten(E4)
wenn du magst, kannst du auch ein Trennzeichen einfügen, es sollte auf beiden Seiten halt das gleiche sein.
3. Sortiere Sheet(2) nach Spalte A aufsteigend
4. füge in Sheet(1) eine weiter Hilfsspalte (Spalte B) ein, in dieser ermittelst du, ob und in welcher Zeile der Eintrag in Sheet(2) vorkommt, dazu verwendest du folgende Formel in Spalte B:
=Wenn(SVerweis(A4;Sheet(2)Name!A:A;1;1)=A4;Vergleich(A4;Sheet(2)Name!A:A;1);"")
5. kopiere Spalte A:B und füge sie an gleicher Stelle als Wert ein
6. sortiere Sheet(1) nach Spalte B, so dass alle Zeilen, in die Werte aus Sheet(2) eingefügt werden sollen, einen lückenlosen Block bilden.
füge jetzt in die benötigten Spalten in dem Bereich in dem in Spalte B eine Zahl steht, folgende Index-Formel ein, um die Werte aus Sheet(2) auszulesen:
D4 (war früher B4): =Index(Sheet(2)Name!C:C;B4)
danach dann alles kopieren und an gleicher Stelle als Wert einfügen, dann Spalte A:B löschen und ggf in die ursprüngliche Reihenfolge zurücksortieren.
das dürfte hier das schnellste sein.
ich gehe mal davon aus, dass wenn du das beherrscht, die Durchführung dieses manuellen Vorgangs schneller geht als dein Makro.
um wieviel schneller muss es dann sein, wenn du das per Code ausführen lässt.
Gruß Daniel

Sub Uebertrag_Sheet2_Sheet1() Dim dic As Object Dim sp1, sp2 Dim rng1 As Range, rng2 As Range Dim arr1, arr2 Dim Werte Dim i As Long Dim z As Long Dim ID As String Set dic = CreateObject("Scripting.dictionary") With Sheets(1) Set rng1 = .Range(.Cells(4, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Resize(, 14) arr1 = rng1.Value End With With Sheets(2) Set rng2 = .Range(.Cells(2, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Resize(, 12) arr2 = rng2.Value End With sp1 = Array(2, 4, 7, 8, 11, 12, 13, 14) sp2 = Array(2, 3, 7, 8, 9, 10, 11, 12) For z = 1 To UBound(arr2, 1) ID = Trim(arr2(z, 1)) & Trim(arr2(z, 4)) ReDim Werte(0 To UBound(sp2)) For i = 0 To UBound(sp2) Werte(i) = arr2(z, sp2(i)) Next dic(ID) = Werte Next For z = 1 To UBound(arr1, 1) ID = Trim(arr1(z, 3)) & Trim(arr1(z, 5)) If dic.exists(ID) Then Werte = dic(ID) For i = 0 To UBound(Werte) arr1(z, sp1(i)) = Werte(i) Next End If Next rng1.Value = arr1 End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread