Hallo liebe Community,

ich habe mal wieder ein Problem. Ich bekomme regelmäßig Tabellen zugeschickt, die aber zur Weiterverarbeitung in Pivot-Tabellen zusammengeführt werden müssen. Die Vorbereitung soll nun ein Makro erledigen.

Ich habe auch schon vieles selbst programmiert, doch tritt ein Problem auf.

Habe ich diese Tabell erhalten, sollen als erstes per Makro die zusammengefügten Zellen aufgelöst werden. Das geschieht wiefolgt:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16

Dim rng1 As Range Dim sh As Worksheet On Error Resume Next 'falls in einem Blatt kein Eintrag ist For Each sh In Worksheets     Set rng1 = sh.Cells.SpecialCells(xlCellTypeConstants, 23)     For Each zelle In rng1         If zelle.MergeCells Then             With zelle.MergeArea             .UnMerge             .HorizontalAlignment = xlCenterAcrossSelection             .VerticalAlignment = xlCenter             .Orientation = 0             End With         End If     Next Next

Das funktioniert soweit auch. Ich kann jede einzelne Zelle separat anklicken und so weiter.

Sind die Zellen nun zusammengefügt, steht der Wert, der eigentlich in der zusammengefügten Zelle stand, ganz oben in der ersten Zelle. Dieser Wert soll jetzt allerdings in jeder Zelle der Spalte stehen, bis ein neuer Wert in der jeweiligen Spalte auftritt.

Dafür habe ich folgenden Code gebaut:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20

letzteZ = Tabelle4.Cells(Rows.Count, 8).End(xlUp).Row   For a = 1 To letzteZ 'geht die erste spalte durch   'wenn ein wert in der aktuellen zelle ist, dh wenn der value ungleich 0     If (Tabelle4.Cells(a, 2)) <> 0 Then             wert = Tabelle4.Cells(a, 2).Value                 b = a + 1     Do While (Tabelle4.Cells(b, 2) = "") And b < letzteZ          Tabelle4.Cells(b, 2) = wert       b = b + 1     Loop         Else     End If Next a

Das klappt allerdings nicht vollständig.

Kann mir bitte jemand helfen? :S Wenn genauere Infos benötigt werden, bitte einfach fragen!

Grüezi Timotheus

Versuche das doch mal mit den folgenden Zeilen:

Code :

1 2 3 4 5 6 7

Sub Fill_EmptyCells()    ' Hier ev. den Bereich anpassen     With Intersect(Columns("A:A"), ActiveSheet.UsedRange)         .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"         .Value = .Value     End With End Sub

Klasse! Hat nach kurzem Anpassen perfekt gepasst danke an Dich!