Zusammenfassen von Daten mit mehr. Suchkriterien

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

…Urmila,
die hat doch mit der Quelle nur den Inhalt gemein und muss sich nicht auch noch in der Form angleichen?!
Also steht zu vermuten, dass du das letzte Mal dein eigentliches Problem, wie das leider recht oft geschieht, gar nicht, sondern einen Zwischenstand deiner Überlegungen dargestellt hast. Damit hast du von vornherein die Chance vertan, eine optimale Lösung zu erhalten, die ich dir diesmal auch nicht geben werde, zumal du deinen letzten Thread gar nicht und meinen letzten Beitrag in dem davor auch nicht beantwortet hast und ich jetzt auch keine Zeit mehr dafür habe.
Nur soviel; in deinem Fall sollte ein einfaches Verbinden der Zellinhalte genügen, zB mit der UDF MxJoin aus dem Archiv. Darin findest du dann auch noch diverse Beiträge zu VerbundZellen, u.a. zum Verbinden von Texten mehrerer Zellen in der 1.Zelle einer VerbundZelle inkl Übernahme der SchriftFarbe (als BspDatei), sowie ein DemoPgm zur Simulation des entsprd Features von LO/OOcalc. Mit letzterer Software könntest du dein Problem auch lösen, alles wieder als .xlsx speichern und wieder in Xl öffnen.
Gruß, Luc :-?

Option Explicit Sub test_mitzelle() Dim wkstab As Worksheet Set wkstab = ActiveWorkbook.Worksheets("Tabelle1") Dim zeilews As Long, endetb As Long, verb As Long, namtn As Long, pers As Double, preis As _ Double endetb = wkstab.Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False With wkstab .Range(.Cells(2, 8), .Cells(endetb, 13)).ClearContents .Range(.Cells(2, 8), .Cells(endetb, 13)).UnMerge For zeilews = 2 To endetb If WorksheetFunction.CountIfs(.Range(.Cells(2, 1), .Cells(zeilews, 1)), .Cells(zeilews, 1), _ .Range(.Cells(2, 2), .Cells(zeilews, 2)), .Cells(zeilews, 2), _ .Range(.Cells(2, 3), .Cells(zeilews, 3)), .Cells(zeilews, 3)) = _ 1 Then verb = WorksheetFunction.CountIfs(.Range(.Cells(2, 1), .Cells(endetb, 1)), .Cells(zeilews, 1), _ _ .Range(.Cells(2, 2), .Cells(endetb, 2)), .Cells(zeilews, 2), _ .Range(.Cells(2, 3), .Cells(endetb, 3)), .Cells(zeilews, 3)) - 1 For namtn = zeilews To zeilews + verb .Cells(zeilews, 11) = .Cells(zeilews, 11) & "; " & .Cells(namtn, 4) pers = pers + .Cells(namtn, 5) preis = preis + .Cells(namtn, 6) Next namtn .Cells(zeilews, 8) = .Cells(zeilews, 1) .Range(.Cells(zeilews, 8), .Cells(zeilews + verb, 8)).Merge .Cells(zeilews, 9) = .Cells(zeilews, 2) .Range(.Cells(zeilews, 9), .Cells(zeilews + verb, 9)).Merge .Cells(zeilews, 10) = .Cells(zeilews, 3) .Range(.Cells(zeilews, 10), .Cells(zeilews + verb, 10)).Merge .Cells(zeilews, 11).WrapText = True .Cells(zeilews, 11) = Application.Substitute(.Cells(zeilews, 11), "; ", , 1) .Range(.Cells(zeilews, 11), .Cells(zeilews + verb, 11)).Merge .Cells(zeilews, 12) = pers .Range(.Cells(zeilews, 12), .Cells(zeilews + verb, 12)).Merge .Cells(zeilews, 13) = preis .Range(.Cells(zeilews, 13), .Cells(zeilews + verb, 13)).Merge End If pers = 0 preis = 0 Next zeilews End With Application.ScreenUpdating = True End Sub

Hallo Urmila,
es geht bestimmt noch besser, zumal es hier im Forum Profis gibt, die dass ganze bestimmt anders lösen würden.
Beim Testen ist mir z.B. aufgefallen, dass die Zeilenhöhen in der Tabelle geändert werden, durch den Zeilenumbruch.
Habe dass noch geändert, aber für einen guten Code solltest Du Dich an die Profis wenden!!!

Sub test_mitzelle()
Dim wkstab As Worksheet
Set wkstab = ActiveWorkbook.Worksheets("Tabelle1")
Dim zeilews As Long, endetb As Long, verb As Long, namtn As Long, pers As Double, preis As  _
Double
endetb = wkstab.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
With wkstab
With .Range(.Cells(2, 8), .Cells(endetb, 13))
.ClearContents
.UnMerge
.WrapText = False
End With
For zeilews = 2 To endetb
If WorksheetFunction.CountIfs(.Range(.Cells(2, 1), .Cells(zeilews, 1)), .Cells(zeilews, 1), _
.Range(.Cells(2, 2), .Cells(zeilews, 2)), .Cells(zeilews, 2), _
.Range(.Cells(2, 3), .Cells(zeilews, 3)), .Cells(zeilews, 3)) =  _
1 Then
verb = WorksheetFunction.CountIfs(.Range(.Cells(2, 1), .Cells(endetb, 1)), .Cells(zeilews, 1), _
_
.Range(.Cells(2, 2), .Cells(endetb, 2)), .Cells(zeilews, 2), _
.Range(.Cells(2, 3), .Cells(endetb, 3)), .Cells(zeilews, 3)) - 1
For namtn = zeilews To zeilews + verb
.Cells(zeilews, 11) = .Cells(zeilews, 11) & "; " & .Cells(namtn, 4)
pers = pers + .Cells(namtn, 5)
preis = preis + .Cells(namtn, 6)
Next namtn
.Cells(zeilews, 8) = .Cells(zeilews, 1)
.Range(.Cells(zeilews, 8), .Cells(zeilews + verb, 8)).Merge
.Cells(zeilews, 9) = .Cells(zeilews, 2)
.Range(.Cells(zeilews, 9), .Cells(zeilews + verb, 9)).Merge
.Cells(zeilews, 10) = .Cells(zeilews, 3)
.Range(.Cells(zeilews, 10), .Cells(zeilews + verb, 10)).Merge
.Cells(zeilews, 11) = Application.Substitute(.Cells(zeilews, 11), "; ", , 1)
With .Range(.Cells(zeilews, 11), .Cells(zeilews + verb, 11))
.Merge
.WrapText = True
End With
.Cells(zeilews, 12) = pers
.Range(.Cells(zeilews, 12), .Cells(zeilews + verb, 12)).Merge
.Cells(zeilews, 13) = preis
.Range(.Cells(zeilews, 13), .Cells(zeilews + verb, 13)).Merge
End If
pers = 0
preis = 0
Next zeilews
End With
Application.ScreenUpdating = True
End Sub

MfG Christian

Beliebteste Forumthreads (12 Monate)

Zusammenfassen von Daten mit mehr. Suchkriterien

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread