Hallo,

ich hoffe es ist okay, wenn ich mich mit meinem ähnlichen Problem an dieses Thema dranhänge.

Ich habe folgendes Programm (s.u.) geschrieben, das für ein Arbeitsblatt mit gut 16.000 Zeilen gedacht ist. Zum Testen habe ich es aber erstmal nur über 10, dann 1000 Zeilen usw. laufen lassen.

Ab 5000 Zeilen dauert es dann mehrere Minuten, bei einer Prozessorauslastung von ebenfalls 25 % und dem Programmstatus „Keine Rückmeldung“. Über 10000 Zeilen geht dann gar nichts mehr bzw. meine Geduld reicht nicht länger als 20 Minuten.

Meine Frage ist: Liegt das an meinen mangelnden VBA-Kenntnissen und ungeschickter Programmsteuerung oder sind das Dimensionen bei denen Excel einfach in die Knie geht?

Beste Grüße

-Moritz-

Option Explicit

Sub aehnliche_artikel()

Dim sku_array(1 To 50) As String, pos As Integer, sku_list As String

Dim aa_a As String, aa_b As String, equal As Boolean

Dim i As Integer, k As Integer, m As Integer, row_count As Integer

Dim i_col As Integer, sku_col As Integer, aa_col As Integer


' Spalten-Nummern von SKU und AA abspeichern

  With ThisWorkbook.Worksheets("Tabelle1")
        For i_col = 1 To 256
            Select Case .Cells(1, i_col).Value
                Case "stock_model"
                sku_col = i_col
                Case "free_aehnliche_artikel"
                aa_col = i_col

                    Exit For
                End Select
        Next i_col
    End With
                

row_count = 12000
Erase sku_array
sku_list = ""
pos = 1


  With ThisWorkbook.Worksheets("Tabelle1")
    .Columns(aa_col + 1).Insert
    .Columns(aa_col + 1).Select
    Selection.NumberFormat = "@"
    .Cells(1, aa_col + 1).Value = row_count
    
    
        For i = 2 To row_count
            aa_a = .Cells(i, aa_col).Value


                 For k = 2 To row_count
                    aa_b = .Cells(k, aa_col).Value
                    If i <> k And aa_a = aa_b And aa_a <> "" Then equal = True Else equal = False
                    If equal = True Then
                        sku_array(pos) = .Cells(k, sku_col).Value
                        pos = pos + 1
                    End If
                Next k

                    sku_list = sku_array(1)
                    For m = 2 To pos - 1
                        sku_list = sku_list & ";" & sku_array(m)
                    Next m
                    sku_list = sku_list & sku_array(pos)
            
            
            .Cells(i, aa_col + 1).Value = sku_list
            Erase sku_array
            sku_list = ""
            pos = 1
        Next i
        
    End With
          
End Sub