Vergleichen Schleife aufteilen bzw. splitten

Public Sub button12(control As IRibbonControl) ' Geburtsdaten vergleichen With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Sheets("Vergleich").Select Dim wksCriteria As Worksheet, WksData As Worksheet, wksTrue As Worksheet Dim var As Variant Dim iRow As Long, iRowL As Long Set wksCriteria = Worksheets("Referenz") Set WksData = Worksheets("Vergleich") Set wksTrue = Worksheets("Geburtsdaten") iRow = 2 Do Until IsEmpty(wksCriteria.Cells(iRow, 3)) var = Application.Match(wksCriteria.Cells(iRow, 3), WksData.Columns(3), 0) If Not IsError(var) Then iRowL = wksTrue.Cells(Rows.Count, 1).End(xlUp).Row + 1 wksTrue.Rows(iRowL).Value = wksCriteria.Rows(iRow).Value wksTrue.Cells(iRowL, 6).Value = Cells(var, 1).Value wksTrue.Cells(iRowL, 7).Value = Cells(var, 2).Value wksTrue.Cells(iRowL, 8).Value = Cells(var, 3).Value wksTrue.Cells(iRowL, 9).Value = Cells(var, 4).Value End If iRow = iRow + 1 Loop wksTrue.Columns("E:E").ClearContents With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .Calculate End With Sheets("Geburtsdaten").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Public Sub button12(control As IRibbonControl) ' Geburtsdaten vergleichen With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Sheets("Vergleich").Select Dim wksCriteria As Worksheet, WksData As Worksheet, wksTrue As Worksheet Dim var As Variant Dim iRow As Long, iRowL As Long Set wksCriteria = Worksheets("Referenz") Set WksData = Worksheets("Vergleich") Set wksTrue = Worksheets("Geburtsdaten") iRow = 2 redo_loop: Do Until IsEmpty(wksCriteria.Cells(iRow, 3)) var = Application.Match(wksCriteria.Cells(iRow, 3), WksData.Columns(3), 0) If Not IsError(var) Then iRowL = wksTrue.Cells(Rows.Count, 1).End(xlUp).Row + 1 wksTrue.Rows(iRowL).Value = wksCriteria.Rows(iRow).Value wksTrue.Cells(iRowL, 6).Value = Cells(var, 1).Value wksTrue.Cells(iRowL, 7).Value = Cells(var, 2).Value wksTrue.Cells(iRowL, 8).Value = Cells(var, 3).Value wksTrue.Cells(iRowL, 9).Value = Cells(var, 4).Value End If iRow = iRow + 1 if iRow mod 5000 = 0 then goto exit_loop end if Loop wksTrue.Columns("E:E").ClearContents With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .Calculate End With Sheets("Geburtsdaten").Select exit sub exit_loop: goto redo_loop End Sub

Option Explicit Sub Test1() ' Geburtsdaten vergleichen Dim arrC, lngC As Long, zC As Long Dim arrD, lngD As Long, zD As Long Dim arrT(), lngT As Long, zT As Long, cc As Long Const lngSp As Long = 12 ' Anz. Spalten in wksCrit With Worksheets("Referenz") ' wksCrit lngC = .Cells(.Rows.Count, 1).End(xlUp).Row arrC = .Cells(2, 1).Resize(lngC - 1, lngSp) End With With Worksheets("Vergleich") ' wksData lngD = .Cells(.Rows.Count, 1).End(xlUp).Row arrD = .Cells(1, 1).Resize(lngD, 4) End With ReDim arrT(1 To lngSp, 1 To lngC - 1) Worksheets("Geburtsdaten").Select ' wksTrue For zC = 1 To lngC - 1 For zD = 1 To lngD If arrC(zC, 1) = arrD(zD, 3) Then zT = zT + 1 For cc = 1 To 4 arrT(cc, zT) = arrC(zC, cc) Next cc For cc = 6 To 9 arrT(cc, zT) = arrD(zD, cc - 5) Next cc For cc = 10 To lngSp arrT(cc, zT) = arrC(zC, cc) Next cc End If Next zD Next zC If zT > 0 Then ReDim Preserve arrT(1 To lngSp, 1 To zT) Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1). _ Resize(UBound(arrT, 2), UBound(arrT)) = Application.Transpose(arrT) End If End Sub

Option Explicit Sub Test2() ' Geburtsdaten vergleichen Dim arrC, lngC As Long, zC As Long Dim arrD, lngD As Long, zD As Long Dim arrT(), lngT As Long, zT As Long, cc As Long With Worksheets("Referenz") ' wksCrit lngC = .Cells(.Rows.Count, 1).End(xlUp).Row arrC = .Cells(2, 1).Resize(lngC - 1, 4) End With With Worksheets("Vergleich") ' wksData lngD = .Cells(.Rows.Count, 1).End(xlUp).Row arrD = .Cells(1, 1).Resize(lngD, 4) End With ReDim arrT(1 To 9, 1 To lngC - 1) Worksheets("Geburtsdaten").Select ' wksTrue For zC = 1 To lngC - 1 For zD = 1 To lngD If arrC(zC, 3) = arrD(zD, 3) Then zT = zT + 1 For cc = 1 To 4 arrT(cc, zT) = arrC(zC, cc) arrT(cc + 5, zT) = arrD(zD, cc) Next cc End If Next zD Next zC If zT > 0 Then ReDim Preserve arrT(1 To 9, 1 To zT) Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(zT, 9) = _ Application.Transpose(arrT) End If End Sub

Public Sub button12(control As IRibbonControl) ' Geburtsdaten vergleichen With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Sheets("Vergleich").Select Dim wksCriteria As Worksheet, WksData As Worksheet, wksTrue As Worksheet Dim var As Variant Dim iRow As Long, iRowL As Long Set wksCriteria = Worksheets("Referenz") Set WksData = Worksheets("Vergleich") Set wksTrue = Worksheets("Geburtsdaten") iRow = 2 redo_loop: Do Until IsEmpty(wksCriteria.Cells(iRow, 3)) var = Application.Match(wksCriteria.Cells(iRow, 3), WksData.Columns(3), 0) If Not IsError(var) Then iRowL = wksTrue.Cells(Rows.Count, 1).End(xlUp).Row + 1 wksTrue.Rows(iRowL).Value = wksCriteria.Rows(iRow).Value wksTrue.Cells(iRowL, 6).Value = Cells(var, 1).Value wksTrue.Cells(iRowL, 7).Value = Cells(var, 2).Value wksTrue.Cells(iRowL, 8).Value = Cells(var, 3).Value wksTrue.Cells(iRowL, 9).Value = Cells(var, 4).Value End If iRow = iRow + 1 if iRow mod 5000 = 0 then thisworkbook.save goto exit_loop end if Loop wksTrue.Columns("E:E").ClearContents With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .Calculate End With Sheets("Geburtsdaten").Select exit sub exit_loop: goto redo_loop End Sub

Sub Test3() ' Geburtsdaten vergleichen Dim arrC, lngC As Long, zC As Long Dim arrD, lngD As Long, zD As Long Dim arrT(), lngT As Long, zT As Long, cc As Long With Worksheets("Referenz") ' wksCrit lngC = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 arrC = .Cells(2, 1).Resize(lngC, 4) End With With Worksheets("Vergleich") ' wksData lngD = .Cells(.Rows.Count, 1).End(xlUp).Row arrD = .Cells(1, 1).Resize(lngD, 4) End With ReDim arrT(1 To 9, 1 To lngC) Worksheets("Geburtsdaten").Select ' wksTrue For zC = 1 To lngC For zD = 1 To lngD If arrC(zC, 3) = arrD(zD, 3) Then zT = zT + 1 If zT > UBound(arrT, 2) Then ReDim Preserve arrT(1 To 9, 1 To 2 * zT) For cc = 1 To 4 arrT(cc, zT) = arrC(zC, cc) arrT(cc + 5, zT) = arrD(zD, cc) Next cc End If Next zD Next zC If zT > 0 Then ReDim Preserve arrT(1 To 9, 1 To zT) Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(zT, 9) = _ Application.Transpose(arrT) End If End Sub

If zT > 0 Then MsgBox Cells(Rows.Count, 1).End(xlUp).Row & vbLf & zT & vbLf & Rows.Count ReDim Preserve arrT(1 To 9, 1 To zT) Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(zT, 9) = _ Application.Transpose(arrT) End If End Sub

Option Explicit Sub Test5() ' Geburtsdaten vergleichen Dim arrC, lngC As Long, zC As Long Dim arrD, lngD As Long, zD As Long Dim arrT(), lngT As Long, zT As Long, cc As Long Const lngZAus As Long = 50000 ' hiermit kannst du spielen With Worksheets("Referenz") ' wksCrit lngC = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 arrC = .Cells(2, 1).Resize(lngC, 4) End With With Worksheets("Vergleich") ' wksData lngD = .Cells(.Rows.Count, 1).End(xlUp).Row arrD = .Cells(1, 1).Resize(lngD, 4) End With ReDim arrT(1 To 9, 1 To lngZAus) Worksheets("Geburtsdaten").Select ' wksTrue For zC = 1 To lngC For zD = 1 To lngD If arrC(zC, 3) = arrD(zD, 3) Then If zT >= UBound(arrT, 2) Then Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(zT, 9) = _ Application.Transpose(arrT) ReDim arrT(1 To 9, 1 To lngZAus) ' arrT initialisieren zT = 0 End If zT = zT + 1 For cc = 1 To 4 arrT(cc, zT) = arrC(zC, cc) arrT(cc + 5, zT) = arrD(zD, cc) Next cc End If Next zD Next zC If zT > 0 Then ' MsgBox Cells(Rows.Count, 1).End(xlUp).Row & vbLf & zT & vbLf & Rows.Count ReDim Preserve arrT(1 To 9, 1 To zT) Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(zT, 9) = _ Application.Transpose(arrT) End If End Sub

Hi Volker,
das freut mich! Ja, das mit Spalte A stimmt so, mehr ist nicht zu tun.
Hier habe ich noch eine etwas sicherere und hoffentlich schnellere Variante:


Sub Test6a()                                     ' Vergleich bei großen Datenmengen
Dim arrC, lngC As Long, zC As Long, arrTC()
Dim arrD, lngD As Long, zD As Long, arrTD()
Dim lngT As Long, zT As Long, cc As Long
Const lngZAus As Long = 30000                ' Zeilenzahl für Zwischen-Ausgabe
With Worksheets("Referenz")                        ' Liste 1
lngC = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '  ab Zeile 2
arrC = .Cells(2, 1).Resize(lngC, 4)             '  Spalten A:D
End With
With Worksheets("Vergleich")                       ' Liste 2
lngD = .Cells(.Rows.Count, 1).End(xlUp).Row     '  ab Zeile 1
arrD = .Cells(1, 1).Resize(lngD, 4)             '  Spalten A:D
End With
ReDim arrTC(1 To 4, 1 To lngZAus)                  ' Ausgabe-Arrays
ReDim arrTD(1 To 4, 1 To lngZAus)
Worksheets("Geburtsdaten").Select                  ' Ausgabeblatt
lngT = Cells(Rows.Count, 1).End(xlUp).Row
For zC = 1 To lngC
For zD = 1 To lngD
If arrC(zC, 1) = arrD(zD, 1) Then            ' Vergleich der Spalten A
If zT >= UBound(arrTC, 2) Then            ' Zwischen-Ausgabe
Cells(lngT + 1, 1).Resize(zT, 4) = Application.Transpose(arrTC)
Cells(lngT + 1, 6).Resize(zT, 4) = Application.Transpose(arrTD)
ReDim arrTC(1 To 4, 1 To lngZAus)      ' arrTx initialisieren
ReDim arrTD(1 To 4, 1 To lngZAus)
lngT = lngT + lngZAus
zT = 0
ActiveWorkbook.Save               ' ... Mutter der Porzellankiste
End If
zT = zT + 1
For cc = 1 To 4
arrTC(cc, zT) = arrC(zC, cc)
arrTD(cc, zT) = arrD(zD, cc)
Next cc
End If
Next zD
Next zC
Erase arrC, arrD
ReDim Preserve arrTC(1 To 4, 1 To zT)              ' Rest-Ausgabe
Cells(lngT + 1, 1).Resize(zT, 4) = Application.Transpose(arrTC)
Erase arrTC
ReDim Preserve arrTD(1 To 4, 1 To zT)
Cells(lngT + 1, 6).Resize(zT, 4) = Application.Transpose(arrTD)
End Sub

Du könntest auch noch ausprobieren, ob das Makro schneller läuft,
wenn du die Zeilen


For cc = 1 To 4
arrTC(cc, zT) = arrC(zC, cc)
arrTD(cc, zT) = arrD(zD, cc)
Next cc

ersetzt durch

            arrTC(1, zT) = arrC(zC, 1)
arrTC(2, zT) = arrC(zC, 2)
arrTC(3, zT) = arrC(zC, 3)
arrTC(4, zT) = arrC(zC, 4)
arrTD(1, zT) = arrD(zD, 1)
arrTD(2, zT) = arrD(zD, 2)
arrTD(3, zT) = arrD(zD, 3)
arrTD(4, zT) = arrD(zD, 4)

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Vergleichen Schleife aufteilen bzw. splitten

29 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread