kleine Änderung eines Makros

Option Explicit
' Anwendungsname
Const conNAME As String = "AddEndOfRow_WoDup"
' Berechnungsmodus merken
Dim cState As Variant
Sub AddEndOfRow_WoDup()
On Error GoTo EH
' AutoBerechnung abschalten, ScreenUpdating abschalten
Call AutoFunctions(False)
' Parameter ggf. anpassen
' Tabellenname > ggf. Anpassen
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Gesamt")
' Schalter für Wiederholungen (True/False)
Dim blnDublikate As Boolean
blnDublikate = False
' Spalte ab der die ermittelten Wert eingetragen werden sollen (M)
Dim lTargetColum As Long
lTargetColum = 13
' Max. Spalte
Dim lMaxColumn As Long
lMaxColumn = 16384
' Spaltendefinitionen Key 1 & 2, und Value
Dim lColumnKey1 As Long
Dim lColumnKey2 As Long
Dim lColumnValue As Long
lColumnKey1 = 1  '(A)
lColumnKey2 = 5  '(E)
lColumnValue = 4 '(D)
With ws
' Bereich dyn. ermitteln
Dim rng As Range
Set rng = .Range("A1").CurrentRegion.Resize(, 6)
Dim ArrayList01 As Object  'New ArrayList
Set ArrayList01 = CreateObject("system.collections.arraylist")
Dim strKeyAE As String
Dim strValueD As String
' Zeile in der Range
Dim r As Variant
' Array für Key u. Value
Dim x(1) As String
' Spaltenfortschritt
Dim c As Long
' Item d. ArrayListObjects
Dim j As Variant
' Alle Zeilen durchlaufen
For Each r In rng.Rows
' Wert aus jew. Zeile und Spalte D
strValueD = r.Cells(1, lColumnValue).Value
' Nur die Zeilen verarbeiten, in denen Spalte 4 (D) nicht leer ist
If Not strValueD = "" Then
' Schlüssel aus Spalte 1(A) und 5 (E) bilden
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Schlüssel und Wert dem Array x zuweisen welches im ArrayListObjekt  _
gespeichert wird
x(0) = strKeyAE
x(1) = strValueD
' Array x in der ArrayList01 als weiteres Element speichern.
ArrayList01.Add x
End If
Next r
' ArrayList zum Merken der Verarbeiteten Schlüssel
Dim ArrayListOc As Object 'New ArrayList
Set ArrayListOc = CreateObject("system.collections.arraylist")
For Each r In rng.Rows
c = 0
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Abgearbeiteten Schlüssel merken
With ArrayListOc
' Schlüssel die bereits verarbeitet wurden stehen im ArrayListOc.
' weiter in der For-Schleife mit dem nächsten Schlüssel.
If Not .Contains(strKeyAE) Then
' Neuen Schlüssel merken
.Add strKeyAE
For Each j In ArrayList01
If strKeyAE = j(0) Then
With r.Cells(1, lTargetColum)
If Not .Value = "" Then
' Abbruch wenn die letzte Zelle nich leer ist
If r.Cells(1, lMaxColumn)  "" Then
MsgBox "Zelle " & r.Cells(1, lMaxColumn).Address & "  _
ist nicht leer." & vbCrLf & _
"Die Verarbeitung wird abgebrochen", vbCritical + _
vbOKOnly, conNAME
End
End If
With r.Cells(1, lMaxColumn).End(xlToLeft).Offset(0, 1)
.Value = j(1)
'.Interior.Color = rgbLightCoral
End With
Else
With r.Cells(1, lTargetColum + c)
.Value = j(1)
'.Interior.Color = rgbLightGreen
End With
' Spaltenvorschub
c = c + 1
End If
End With
End If
Next j
End If
End With
Next r
' Löschen der Spalte lColumnValue ('D')
.Cells(1, lColumnValue).EntireColumn.ClearContents
End With
' Aufruf von Routine zur Duplikatenentfernung mit dynamischem Bereich, Kontrollspalten 1  u. _
5 =
' (Array of indexes of the columns that contain the duplicate information)
Call KillDup(ws, Array(lColumnKey1, lColumnKey2))
' AutoBerechnung abschalten, ScreenUpdating abschalten
Call AutoFunctions(True)
Exit Sub
EH:
Application.ScreenUpdating = True
Application.Calculate
Application.Calculation = cState
End Sub
' Private Sub AutoFunctions(blnAutoFunctions)
' Schaltet die automatische Berechnung und die automatische
' Bildschirmaktualisierung an bzw. aus. Dies über den boolschen
' Parameter  blnAutoFunctions geschaltet. True = AutoBereichnung.
' False = Man. Bereichnung. Wird aus der Haubptroutine aufgerufen.
Private Sub AutoFunctions(blnAutoFunctions As Boolean)
With Application
If blnAutoFunctions = False Then
' Einstellung merken
cState = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
Else
.Calculate
' Bereichnen Einstellung wieder herstellen
.Calculation = cState
.ScreenUpdating = True
End If
End With
End Sub
' Private Function GetRange(ws As Worksheet) As Range
' GetRange ermittelt den akt. genutzten Bereich im übergebenen
' Tabellenblatt, ausgehend von A1 bis zur maxZeile und maxSpalte
' und gibt ein Range Objekt zurück
Private Function GetRange(ws As Worksheet) As Range
Dim r As Long, c As Long
With ws
' Max Row und Max Col ermitteln
' Max Rows, Ausgehend von A1. Keine Leerzeilen erlaubt!
r = .Range("A1").CurrentRegion.Resize(, 6).Rows.Count
' Durchsucht die gesamte Tabelle nach nichtleeren Zellen von links nach rechts
c = .Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
' Objekt zurückgeben
Set GetRange = .Range("A1" & ":" & .Cells(r, c).Address)
End With
End Function
' Private Sub KillDup(ws As Worksheet, x As Variant)
' Führt die Excel-interne RemoveDuplicates Methode aus.
' Parameter: a) Worksheet-Object, b) Spalten die auf Duplikate untersucht
' werden.  Es können hier max. 2 Spalten übergeben werden. Es wird angenommen
' dass Range keine Überschriftszeile enthält
Private Sub KillDup(ws As Worksheet, x As Variant)
On Error GoTo EH
' Range ermitteln lassen
' GetRange ermittelt den akt. genutzten Bereich im Tabellenblatt, ausgehend von A1 bis zur  _
maxZeile und maxSpalte
' und gibt ein Range Objekt zurück
Dim rng As Range
Set rng = GetRange(ws)
' Duplikate entfernen
rng.RemoveDuplicates Columns:=Array(x(0), x(1)), Header:=xlNo
Exit Sub
EH:
Application.ScreenUpdating = True
Application.Calculation = cState
End Sub