Supportnet / Forum / Tabellenkalkulation

Hallo Zusammen Ich suche eine Lösung um automatisch Zellen zu Verbinden. Wenn der Wert in der gesamten Spalte A irgendwo gleich „Sternchen“ ist, dann dazugehörige Zelle B bis G verbinden, kursiv machen, Ausrichtung links und B bis G rahmen (Rahmenlinie außen). Bsp. Makro: Sub Makro1() ' ' ActiveCell.FormulaR1C1 = "*" Range("B9:F9").Select Selection.Merge With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Selection.Font.Italic = True End Sub Danke

Hallo jsergej ,
ich habe dir das Makro SternzeilenFormat gemacht, das bei * in Spalte A Spalte B bis G wie gewünscht formatiert und das Makro SternzeilenUnFormat, das bei # in Spalte A, die Formatierung wieder rückgängig macht. Die Makros aktion und aktion2 übernehmen die jeweilige Formatierung.

Sub aktion(c As Range)
'    ActiveCell.FormulaR1C1 = "*"
'    Range("B9:F9").Select
    Range(Cells(c.row, 2), Cells(c.row, 7)).Select
    Selection.Merge
    With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
    End With
    Selection.Font.Italic = True
    
    ' B bis G rahmen (Rahmenlinie außen)
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone


End Sub

Sub SternzeilenFormat()
Dim c As Range
With Worksheets(1).Range("A:A")
    Set c = .Find(what:="~*", LookIn:=xlValues, SearchOrder:=xlByColumns)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            Call aktion(c)
            Set c = .FindNext(c)
        Loop While (Not c Is Nothing) And (c.Address <> firstAddress)
    End If
End With

End Sub

Sub aktion2(c As Range)
'    ActiveCell.FormulaR1C1 = "-"
'    Range("B9:F9").Select
    Range(Cells(c.row, 2), Cells(c.row, 7)).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Selection.Font.Italic = False
    
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub SternzeilenUnFormat()
Dim c As Range
With Worksheets(1).Range("A:A")
    Set c = .Find("#", LookIn:=xlFormulas, SearchOrder:=xlByColumns)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            Call aktion2(c)
            Set c = .FindNext(c)
        Loop While (Not c Is Nothing) And (c.Address <> firstAddress)
    End If
End With

End Sub

Ich hoffe das läuft so.
Gruß
lorf

• Zellen kopieren // *CLOSED* //
• Zellen verbinden ???
• VBA + zellen vergleichen und rausschreiben
• VBA-Problem