Gruppen

Top Gruppen: Windows 7; Windows Vista; Windows XP; Textverarbeitung; Excel; DSL; Internet Browser; E-Mail/Outlook
Betriebsysteme: Windows classik; Linux; BS-Sonstige
Software: Datenbanken; Bildbearbeitung; Audio/mp3/Video; Security/Viren; SW-Sonstige
Hardware: Mainboard/CPU; Grafikkarten; Peripherie; Laptop/Notebook; HW-Sonstiges
Netzwerk: Telefon,ISDN,Modem; W-Lan; NW-Sonstiges
Programmierung: PHP,ASP,Perl...; Java,C++...; Webseiten/HTML
Sonstiges: PC-Sonstiges; Plauderecke; SN Intern; Test

/ Forum / Tabellenkalkulation

Tabellenkalkulation

Fragevon jsergej vom 02.06.2020, 19:52 Options

Zellen Verbinden mit VBA wenn wert gleich "sternchen".

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

Antwort schreiben

Antwort 1 von lorf55 vom 27.06.2020, 19:37 Options

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

Hinweis

Diese Frage ist schon etwas älter, Sie können daher nicht mehr auf sie antworten. Sollte Ihre Frage noch nicht gelöst sein, stellen Sie einfach eine neue Frage im Forum..

Neue Einträge

Tipp einschicken

News einschicken