Hallo Tino,
Du hast mit doch vor ein paar Tagen das Beispiel gemacht (echt supi) mit dem Daten zusammegefasst werden.
Was muss ich denn dran ändern, wenn ich in den Spalten C (3) und U (9) ebenfalls die Kommentare (getrennt duch " ### ") zusammenfügen will. Also gleich , wie es jetzt schon in der Spalte D (4) passiert.
Ist das viel Aufwand ? Vielen dank
Gruss
Joachim
Dim Bereich As Range
Dim LRow As Long, A As Long, B As Long, varRow
Dim meAR1, meAR2, meAr3
Dim iCalc As Integer
With Application
iCalc = .Calculation 'merke einstellung Berechnung auto o. manuell
.ScreenUpdating = False 'Bildschirmaktualisierung aus
.EnableEvents = False 'Events aus
.Calculation = xlCalculationManual 'Berechnung auf Manuell stellen
With Sheets("AutoBill Import") '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 ist die Spalte 256, ab xl2007 ist dies Spalte 16384
With .Range("V10", .Cells(.Rows.Count, 22).End(xlUp)).Offset(0, .Columns.Count - 22)
meAR1 = .Offset(0, -(.Column - 4)) 'Hilfs- Array1 füllen (Spalte D)
meAR2 = .Offset(0, -(.Column - 22)) 'Hilfs- Array2 füllen (Spalte V)
meAr3 = .Offset(0, -(.Column - 22)) 'Hilfs- Array3 füllen (Spalte V)
'hier werden die Texte zusammengefasst,
For A = 1 To UBound(meAR1)
'ist in Sp. V ein X oder ist diese leer?
If meAR2(A, 1) <> "" And meAR2(A, 1) <> "X" Then
B = A 'Hilfszähler
varRow = Application.Match(meAR2(A, 1), meAr3, 0) 'suche weitere davon
Do While IsNumeric(varRow) 'Schleife bis keine Treffer mehr
'ist in Sp. V ein X oder ist diese leer?
If meAR2(varRow, 1) <> "" And meAR2(varRow, 1) <> "X" Then
If B > A Then 'erst ab zweiten Treffer
meAR1(A, 1) = meAR1(A, 1) & " ### " & meAR1(varRow, 1) 'Text zusammenführen
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
Next A
'Letzte Zeile?
LRow = .Rows(.Rows.Count).Row
'Formel für die Summierung der Werte
.FormulaR1C1 = "=IF(OR(RC22="""",RC22=""X""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
"SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C5),""""))"
'Ergebnis zurückschreiben in Bereich
.Offset(0, -(.Column - 5)).Value = .Value
'zusammengeführte Texte in Zellen zurückschreiben
.Offset(0, -(.Column - 4)) = meAR1
'Formel erstellen um immer den ersten Eintrag zu ermitteln
.FormulaR1C1 = "=IF(OR(COUNTIF(R10C22:RC22,RC22)=1,RC22="""",RC22=""X""),ROW(),TRUE)"
'Tebellenname Zelle, damit nicht doppelt angegeben werden muss
With Sheets(.Parent.Name)
'Sortiere den gesamten Bereich, Zeilen die gelöscht werden kommen nach unten
.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
'optimale Spaltenbreite
' .Range("A:V").Columns.AutoFit
End If
End With
.Calculation = iCalc 'Berechnung auf alten zustand zurückstellen
.ScreenUpdating = True 'Bildschirmakt. an
.EnableEvents = True 'Events an
End With