AW: mehrere Zellen in einer Zelle mit Absätzen II
10.12.2008 17:34:50
fcs
Hallo Christian,
folgende nicht getestete Version sollte funktionieren.
Die Zeilen, die nicht dem Kriterium entsprechen werden vor dem Zusammenfaqssen gelöscht.
Die nicht gewünschten Spalten werden zum Schluß gelöscht.
Gruß
Franz
Sub Zusammenfassen()
Dim ze As Long, varWert, Zeile As Long
Dim shA As Worksheet
Dim shE As Worksheet
Set shA = Sheets("Ausgangsdaten")
Set shE = Sheets("Ergebnis")
shA.UsedRange.Copy shE.Cells(1, 1)
With shE
'Alle Zeilen verschieden von Geschenkartikel in Spalte 8 löschen
varWert = "Geschenkartikel"
For ze = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'Vergleichswert mit Zellinhalten vergleichen
If varWert .Cells(ze, 8).Text Then
.Rows(ze).Delete shift:=xlShiftUp
End If
Next
'Spalten vertikal formatieren (zentriert)
With .Range(.Columns(1), .Columns(6))
.VerticalAlignment = xlVAlignCenter
End With
'Spalten als Text formatieren (ohne Spalten mit Dezimalwerten!)
With .Range(.Columns(1), .Columns(5))
.NumberFormat = "@"
End With
'Letzte Zeile ermitteln
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'Nummerischen Wert in Spalte merken und als Text in Zelle eintragen
varWert = .Cells(Zeile, 6).Text
With .Cells(Zeile, 6)
.NumberFormat = "@"
.Value = varWert
End With
'1. Vergleichswert
varWert = .Cells(Zeile, 1).Text & .Cells(Zeile, 2).Text
For ze = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
'Vergleichswert mit Zellinhalten vergleichen
If varWert = .Cells(ze, 1).Text & .Cells(ze, 2).Text Then
.Cells(Zeile, 3) = .Cells(ze, 3).Text & Chr(10) & .Cells(Zeile, 3).Text
.Cells(Zeile, 4) = .Cells(ze, 4).Text & Chr(10) & .Cells(Zeile, 4).Text
.Cells(Zeile, 6) = .Cells(ze, 6).Text & Chr(10) & .Cells(Zeile, 6).Text
.Rows(ze).ClearContents
Else
Zeile = ze 'neue Zeile für "addieren" von Zellinhalten merken
'Inhalt von Zellen mit Nummerischen Werten merken und als Text in Zellen eintragen
varWert = .Cells(Zeile, 6).Text
With .Cells(Zeile, 6)
.NumberFormat = "@"
.Value = varWert
End With
'Neuer Vergleichswert
varWert = .Cells(Zeile, 1).Text & .Cells(Zeile, 2).Text
End If
Next
'Nachkomma-Nullen ersetzen
.Columns(6).Replace ",00", ",--"
'Leerzeilen löschen
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Spalten löschen
.Columns(4).Delete shift:=xlShiftToLeft
End With
End Sub
