Hallo zusammen,
ich würde gern verbundene Zellen trennen und als Ergebnis mehrere Zellen mit dem Selben Inhalt haben Anstat den Inhalt in einer Zelle und die anderen sind leer.
Es sind ca. 2000 Verbundene Zellen die jeweils untereinander stehen.
[
Bild bitte so als Datei hochladen: Klick mich!]
Ist das prinzipiell möglich?
Beste Grüße und Dank im Voraus!
Hi,
wenn du verbundene Zellen auflöst, bleibt ein Wert stehen, den du dann runterkopieren kannst.
Hallo,
verbundene Zellen aufheben - Text in Spalten.
Gruß
Marcus
WillWissen schrieb:Hi,
wenn du verbundene Zellen auflöst, bleibt ein Wert stehen, den du dann runterkopieren kannst.
Genau das manuelle runterkopieren möchte ich verhindern. Gibt es da eine automatische Funktion? Sonst sitze ich da ewig dran (da die verbunden Zeilen unterschiedliche Größe haben).
marose67 schrieb:Hallo,
verbundene Zellen aufheben - Text in Spalten.
Gruß
Marcus
leider ist es Text in Zeilen.
Hallo
so evtl.??
Code:
Sub Makro1()
Dim LR As Long, i As Long, Anz As Integer, RNG As Range
LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
For i = 1 To LR
With Cells(i, 1)
If .MergeCells Then
Set RNG = Cells(i, 1).MergeArea
Anz = .MergeArea.Rows.Count
.MergeCells = False
RNG = .Value
i = i + Anz - 1
End If
End With
Next
End Sub
LG UweD
Ich sehe hier kein Problem. Die verbundenen Zellen aufheben und in der rechten unteren Ecke ein Doppelklick. Dann wird überall der richtige Wert eingesetzt. Das passiert, wenn man mit verbundenen Zellen arbeitet ... Nacharbeit.
Ansonsten bleibt wohl nur ein Makro. Hier einmal mit dem Recorder aufgenommen. Umsetzen kann ich das nicht für eine komplette Tabelle. Lohnt sich für mich aber auch nicht, denn die Programmierung würde länger dauern als das Makro zu programmieren.
Sub Makro1()
'
' Makro1 Makro
'
'
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
ActiveWindow.SmallScroll Down:=6
Range("A19").Select
Selection.AutoFill Destination:=Range("A19:A38"), Type:=xlFillDefault
Range("A19:A38").Select
ActiveWindow.SmallScroll Down:=-27
End Sub
Gruß
Marcus