✔ Vorbereit von Pivot-Tabellen: Zusammengeführte Zellen auflösen und deren Wert kopiere

[Timotheus1992]

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:

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:

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!

 

[Thomas Ramel]

Grüezi Timotheus

Versuche das doch mal mit den folgenden Zeilen:

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

 

[Timotheus1992]

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