Thema: Zellen "merge" - sehr langsam

Hallo Freunde,
ich habe ein Makro um Zellen zu verbinden. Ansich läuft es gut und stabil, jedoch braucht es unheimlich Zeit.
Ich möchte mit 2 If-Abfragen Zellen pro Spalte verbinden, jeweils in den Spalten von A bis U.
Das Problem ist, das es sich hier meist um mehr als 2000 Zeilen handelt, das macht es sehr langsam.
Anbei mein Code. Hat jemand eine Idee, wie man das schneller hinbekommt?
Vielen Dank schon im voraus.


Dim i As Long
Dim lastrow As Long

lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For i = lastrow To 2 Step -1

a = Cells(i, 2).Value
If Cells(i - 1, 2).Value = a Then

a = Cells(i, 1).Value
If Cells(i - 1, 1).Value = a Then
Range(Cells(i - 1, 1), Cells(i, 1)).Merge
End If
a = Cells(i, 2).Value
If Cells(i - 1, 2).Value = a Then
Range(Cells(i - 1, 2), Cells(i, 2)).Merge
End If
a = Cells(i, 3).Value
If Cells(i - 1, 3).Value = a Then
Range(Cells(i - 1, 3), Cells(i, 3)).Merge
End If
a = Cells(i, 4).Value
If Cells(i - 1, 4).Value = a Then
Range(Cells(i - 1, 4), Cells(i, 4)).Merge
End If
a = Cells(i, 5).Value
If Cells(i - 1, 5).Value = a Then
Range(Cells(i - 1, 5), Cells(i, 5)).Merge
End If
a = Cells(i, 6).Value
If Cells(i - 1, 6).Value = a Then
Range(Cells(i - 1, 6), Cells(i, 6)).Merge
End If
a = Cells(i, 7).Value
If Cells(i - 1, 7).Value = a Then
Range(Cells(i - 1, 7), Cells(i, 7)).Merge
End If
a = Cells(i, 8).Value
If Cells(i - 1, 8).Value = a Then
Range(Cells(i - 1, 8), Cells(i, 8)).Merge
End If
a = Cells(i, 9).Value
If Cells(i - 1, 9).Value = a Then
Range(Cells(i - 1, 9), Cells(i, 9)).Merge
End If
a = Cells(i, 10).Value
If Cells(i - 1, 10).Value = a Then
Range(Cells(i - 1, 10), Cells(i, 10)).Merge
End If
a = Cells(i, 11).Value
If Cells(i - 1, 11).Value = a Then
Range(Cells(i - 1, 11), Cells(i, 11)).Merge
End If
a = Cells(i, 12).Value
If Cells(i - 1, 12).Value = a Then
Range(Cells(i - 1, 12), Cells(i, 12)).Merge
End If
a = Cells(i, 13).Value
If Cells(i - 1, 13).Value = a Then
Range(Cells(i - 1, 13), Cells(i, 13)).Merge
End If
a = Cells(i, 14).Value
If Cells(i - 1, 14).Value = a Then
Range(Cells(i - 1, 14), Cells(i, 14)).Merge
End If
a = Cells(i, 15).Value
If Cells(i - 1, 15).Value = a Then
Range(Cells(i - 1, 15), Cells(i, 15)).Merge
End If
a = Cells(i, 16).Value
If Cells(i - 1, 16).Value = a Then
Range(Cells(i - 1, 16), Cells(i, 16)).Merge
End If
a = Cells(i, 17).Value
If Cells(i - 1, 17).Value = a Then
Range(Cells(i - 1, 17), Cells(i, 17)).Merge
End If
a = Cells(i, 18).Value
If Cells(i - 1, 18).Value = a Then
Range(Cells(i - 1, 18), Cells(i, 18)).Merge
End If
a = Cells(i, 19).Value
If Cells(i - 1, 19).Value = a Then
Range(Cells(i - 1, 19), Cells(i, 19)).Merge
End If
a = Cells(i, 20).Value
If Cells(i - 1, 20).Value = a Then
Range(Cells(i - 1, 20), Cells(i, 20)).Merge
End If
a = Cells(i, 21).Value
If Cells(i - 1, 21).Value = a Then
Range(Cells(i - 1, 21), Cells(i, 21)).Merge
End If
a = Cells(i, 22).Value
If Cells(i - 1, 22).Value = a Then
Range(Cells(i - 1, 22), Cells(i, 22)).Merge
End If

End If

Next i

Hi
warum programmierst du jede Spalte einzeln?
lass doch auch eine Schleife über die Spalten laufen.
das machte die Sache zwar nicht schneller, aber den Code kürzer.

schneller wirds, wenn du nicht jede Zelle einzeln verbindest, sondern erstmal den ganzen Block, der zusammen gehört (gleicher Inhalt) ermittelst und dann diesen Block als ganzes verbindest, das reduziert die Anzahl der Merge-Vorgänge:

Sub test()

Application.DisplayAlerts = False

Dim a

Dim i As Long

Dim z As Long

Dim z2 As Long

Dim s As Long

Dim lastrow As Long



lastrow = Cells(Rows.Count, 2).End(xlUp).Row

For s = 1 To 22

    z2 = lastrow

    For z = lastrow To 2 Step -1

        If Cells(z, s) <> Cells(z - 1, s) Then

            If z <> z2 Then

                Range(Cells(z, s), Cells(z2, s)).Merge

            End If

            z2 = z - 1

        End If

    Next

Next

End Sub

oder du machst das ganze so:

Sub test()

Application.DisplayAlerts = False

Dim sp As Range

Dim x

For Each sp In ActiveSheet.UsedRange.Resize(, 22).Columns

    For Each x In WorksheetFunction.Unique(sp)

        sp.Replace x, True, xlWhole

        With sp.SpecialCells(xlCellTypeConstants, 4)

            .Merge

            .Value = x

        End With

    Next

Next

End Sub

Gruß Daniel

Hallo Klaus,

es besteht die Möglichkeit, die gruppierbare Zellen als Adresse zu sammeln und diese in einem Zug zu verbinden.

Folgende Code sollte passen:

Sub zusammenfassen()

Dim i As Long

Dim j As Long

Dim k As Long

Dim Sp As Long

Dim Temp As Range

Dim A As String



    Application.ScreenUpdating = False

    Application.EnableEvents = False

    Application.DisplayAlerts = False

    For i = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1

        j = HängendeBereich(Cells(i, 2)).Row

        If j < i Then

            A = ""

            For Sp = 1 To 22

                k = i

                Do While k > j

                    Set Temp = HängendeBereich(Cells(k, Sp), j)

                    A = A & "," & Temp.Address(0, 0)

                    k = k - Temp.Cells.Count

                Loop

            Next

            Range(Mid(A, 2)).Merge

        End If

    Next

    Application.ScreenUpdating = True

    Application.EnableEvents = True

    Application.DisplayAlerts = True

End Sub



Public Function HängendeBereich(ersteZelle As Range, Optional ObersteZeile As Long = 2) As Range

Dim letzteZelle As Range



    Set letzteZelle = ersteZelle

    On Error GoTo Zeile1

    Do While letzteZelle.Value = ersteZelle.Value

        Set letzteZelle = letzteZelle.Offset(-1)

    Loop

    Set letzteZelle = letzteZelle.Offset(1)

    If letzteZelle.Row < ObersteZeile Then Set letzteZelle = Cells(ObersteZeile, letzteZelle.Column)

Zeile1:

    Set HängendeBereich = Range(ersteZelle, letzteZelle)

End Function

VG
Yal

Hallo Yal,

es funktioniert leider nicht. Das makro steigt aus.

Range(Mid(A, 2)).Merge

Diese Zeile will so nicht.

Gruß Klaus

Hallo Daniel,
danke für deine Hilfe, macht es deutlich schneller.
Aber es fehlt in deinem Code die erste If-Abfrage. Kannst du mir da noch mal helfen?
Gruß Klaus

was macht die erste If-Abfrage denn anders als die anderen IF-Abfragen?
ich war zu faul, deinen Code in der Tiefe zu analsysieren, da ich ihn mangels Daten nicht laufen lassen konnte.
ich lese auch ungern Code ohne jegliche Einrückung.
daher wäre es gut, wenn du einkopierten Code auch als Code formatierst, dann bleiben die Einrückungen erhalten.
aber so ist es ein Qual, das zu lesen.
Gruß Daniel