AW: Spaltenvergleich per Zeile und Zelle kopieren
09.03.2019 21:38:15
fcs
Hallo Oliver,
hier das Makro angepasst inkl. Kommentaren zum leichteren Verständnis.
LG
Franz
Sub Doppelte_Finden_Werte_uebernehmen()
Dim wks As Worksheet
Dim lngZei As Long, lngZei2 As Long
Dim varWert1, varWert2, varWert3, strErgebnis As String
Dim arrData, arrDoppelt() As Boolean
Dim sTrenn As String
Dim bolDoppelt As Boolean, spaDop As Long
Set wks = ActiveSheet
sTrenn = ";"
spaDop = 9 'Spalte I - leere Spalte zur Markierung doppelter Einträge
With wks
'letzte benutzte Zeile im Tabellenblatt
lngZei = .UsedRange.Row + .UsedRange.Rows.Count - 1
'Daten in Array einlesen zur Beschleunigung des Makros
arrData = .Range(.Cells(1, 1), .Cells(lngZei, 8))
'Array zum Merken doppelter Zeilen dimensionieren
ReDim arrDoppelt(LBound(arrData, 1) To UBound(arrData, 1))
For lngZei = LBound(arrData, 1) To UBound(arrData, 1)
If arrData(lngZei, 1) "" Then 'Zeile ohne Wert in Spalte A überspringen
If arrDoppelt(lngZei) = False Then ' als doppelt markierte Zeile überspringen
bolDoppelt = False 'merker für doppelt zurücksetzen
'Vergleichswerte in Variablen merken
varWert1 = arrData(lngZei, 5)
varWert2 = arrData(lngZei, 7)
varWert3 = arrData(lngZei, 8)
strErgebnis = arrData(lngZei, 1) 'Wert in Spalte A als Ergebnis übernehmen
'Zeilen bis zum Ende der Liste mit Vergleichswerten vergleichen
For lngZei2 = lngZei + 1 To UBound(arrData, 1)
If varWert1 = arrData(lngZei2, 5) And varWert2 = arrData(lngZei2, 7) _
And varWert3 = arrData(lngZei2, 8) Then
arrDoppelt(lngZei2) = True 'Zeile als doppelt markieren
'Trennzeichen und Wert in Spalte A an das Ergebnis anfügen
strErgebnis = strErgebnis & sTrenn & arrData(lngZei2, 1)
bolDoppelt = True 'Merker für doppelt setzen
.Cells(lngZei2, spaDop) = "doppelt"
End If
Next
If bolDoppelt = True Then
.Cells(lngZei, 1) = strErgebnis
End If
End If
End If
Next
'Als doppelt markierte Zeilen löschen
With .Range(.Cells(1, spaDop), .Cells(UBound(arrData), spaDop))
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
.SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete shift:= _
xlShiftUp
End If
End With
End With
End Sub