@Tino, Kommentierung von Deinem Beispiel
Deinem
ist die Kommentierung von Deinem Code so einigermassen zutreffend ? Habe mal versucht es soweit wie möglich zu machen. Es war Dein Beispiel mit den Gruppieren von Datensätzen.
DU darfst gerne noch ergänzen, wenn was fehlt, sonst weiss ich in ein paar Wochen nicht mehr, was da genmacht wird.
PS: vielleicht noch eine Frage : kann ich die betroffenen datensätze (mit gleichem Kriterium in V) irgend wie farblich (font) markieren, damit ich nachher noch sehen kann, welche Datensätze vom zusammenfassen betroffen waren.
Das wäre aber nur noch ein Guddi, ist nicht notwendig.
Danke
<pre>Sub Aufbereiten4()
Dim Bereich As Range
Dim LRow As Long, A As Long, B As Long, varRow
Dim meAR1, meAR2, meAr3, meAr4, meAr5
Dim iCalc As Integer
Dim LenZ As Integer
'hier Trennzeichen angeben
Const TrennZeichen As String = " ### "
LenZ = Len(TrennZeichen)
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
With Sheets("Datenseite") 'Tabellennamen anpassen
' prüfen ob Daten ab Zeile 11 vorhanden sind
If .Cells(.Rows.Count, 22).End(xlUp).Row > 10 Then
' verweis auf letzte Spalte in Tabelle (Hilfsspalte)
' unter xl2007 = Spalte 256, ab xl2007 = Spalte 16384
With .Range("V10", .Cells(.Rows.Count, 22).End(xlUp)).Offset(0, .Columns.Count - 22)
meAR2 = .Offset(0, -(.Column - 22))
meAr3 = .Offset(0, -(.Column - 22))
meAR1 = .Offset(0, -(.Column - 4)) 'Spalte D = 4
meAr4 = .Offset(0, -(.Column - 3)) 'Spalte C = 3
meAr5 = .Offset(0, -(.Column - 21)) 'Spalte U = 21
' hier werden die Texte zusammengefasst,
For A = 1 To UBound(meAR1)
meAR1(A, 1) = TrennZeichen & meAR1(A, 1) & TrennZeichen
meAr4(A, 1) = TrennZeichen & meAr4(A, 1) & TrennZeichen
meAr5(A, 1) = TrennZeichen & meAr5(A, 1) & TrennZeichen
' ist in Sp. V ein X oder ist diese leer?
If meAR2(A, 1) <> "" And meAR2(A, 1) <> "S" Then
B = A 'Hilfszähler
varRow = Application.Match(meAR2(A, 1), meAr3, 0)
Do While IsNumeric(varRow)
If meAR2(varRow, 1) <> "" And meAR2(varRow, 1) <> "S" Then
If B > A Then
If InStr(meAR1(A, 1), TrennZeichen & meAR1(varRow, 1) & TrennZeichen) = 0 Then
meAR1(A, 1) = meAR1(A, 1) & meAR1(varRow, 1) & TrennZeichen
End If
If InStr(meAr4(A, 1), TrennZeichen & meAr4(varRow, 1) & TrennZeichen) = 0 Then
meAr4(A, 1) = meAr4(A, 1) & meAr4(varRow, 1) & TrennZeichen
End If
If InStr(meAr5(A, 1), TrennZeichen & meAr5(varRow, 1) & TrennZeichen) = 0 Then
meAr5(A, 1) = meAr5(A, 1) & meAr5(varRow, 1) & TrennZeichen
End If
End If
End If
' was anderes schreiben damit wert nicht zweimal gefunden wird
meAr3(varRow, 1) = "@@@@@"
' Suche weiter in Liste
varRow = Application.Match(meAR2(A, 1), meAr3, 0)
B = B + 1 'Hilfszähler ein hoch
Loop
End If
If Right$(meAR1(A, 1), LenZ) = TrennZeichen Then meAR1(A, 1) = Left$(meAR1(A, 1), Len(meAR1(A, 1)) - LenZ)
If Left$(meAR1(A, 1), LenZ) = TrennZeichen Then meAR1(A, 1) = Right$(meAR1(A, 1), Len(meAR1(A, 1)) - LenZ)
If Right$(meAr4(A, 1), LenZ) = TrennZeichen Then meAr4(A, 1) = Left$(meAr4(A, 1), Len(meAr4(A, 1)) - LenZ)
If Left$(meAr4(A, 1), LenZ) = TrennZeichen Then meAr4(A, 1) = Right$(meAr4(A, 1), Len(meAr4(A, 1)) - LenZ)
If Right$(meAr5(A, 1), LenZ) = TrennZeichen Then meAr5(A, 1) = Left$(meAr5(A, 1), Len(meAr5(A, 1)) - LenZ)
If Left$(meAr5(A, 1), LenZ) = TrennZeichen Then meAr5(A, 1) = Right$(meAr5(A, 1), Len(meAr5(A, 1)) - LenZ)
Next A
' Letzte Zeile?
LRow = .Rows(.Rows.Count).Row
' A summieren
.FormulaR1C1 = "=IF(OR(RC22="""",RC22=""S""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
"SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C1),""""))"
' und zurück schreiben
.Offset(0, -(.Column - 1)).Value = .Value
' E summieren
.FormulaR1C1 = "=IF(OR(RC22="""",RC22=""S""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
"SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C5),""""))"
' Daten zurück schreiben
.Offset(0, -(.Column - 5)).Value = .Value
.Offset(0, -(.Column - 4)) = meAR1 'Spalte D schreiben
.Offset(0, -(.Column - 3)) = meAr4 'Spalte C schreiben
.Offset(0, -(.Column - 21)) = meAr5 'Spalte U schreiben
' Formel für die Summierung der Werte
.FormulaR1C1 = "=IF(OR(COUNTIF(R10C22:RC22,RC22)=1,RC22="""",RC22=""S""),ROW(),TRUE)"
' Tebellenname Zelle, damit nicht doppelt angegeben werden muss
With Sheets(.Parent.Name)
.Range("A10", .Cells(LRow, .Columns.Count)).Sort Key1:=.Cells(10, .Columns.Count), Order1:=xlAscending, Header:=xlNo
End With
On Error Resume Next
' Zeilen löschen die das Ergebnis Wahr haben
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
' Hilfsspalte komplett löschen
.EntireColumn.Delete
On Error GoTo 0
End With
.Range("A:V").Columns.AutoFit
End If
End With
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub</pre>