Zellen einfügen mit Rahmenlinie per Makro

Bild

Betrifft: Zellen einfügen mit Rahmenlinie per Makro
von: corsin cathomen
Geschrieben am: 05.05.2015 08:39:13

Guten Tag zusammen
Ich habe ein Excel-File mit einer Auflistung diverser Projekte, welche in weiteren Zellen noch zusätzliche Angaben haben wie Bereich, Kosten, Projektdauer etc.
Mittlerweile sind es in etwa 400 Projekte. Mein Vorgänger hat ein Makro geschrieben, mit welchem die ausgewählten Projekte in eine anschaubare Form gebracht werden.
Das Makro funktioniert soweit auch. Sobald ich aber mehr als 150 Projekte markiere schmiert Excel leider ab. Ich habe herausgefunden, dass das Problem darin besteht, dass das Makro für die Darstellung leere Zeilen einfügt und eine Rahmenlinie dazwischen setzt.
Hier mal das entsprechende Sub


Sub Zeilen_einfügen()
Sheets("Referenzliste").Select
Range("B5").Select
Do While ActiveCell <> Empty
If ActiveCell <> Empty Then
Do While ActiveCell <> Empty
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Selection.RowHeight = 4
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Selection.RowHeight = 4
ActiveCell.Offset(0, 5).Select
'Stoppmarke für ToRightRange setzen
ActiveCell = "E"
ActiveCell.Offset(0, -5).Select
'Haarlinie einfügen
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    ActiveCell.Select
'Zellverbindungen einfügen
Do While ActiveCell <> "E"
   Range(Selection, Selection.End(xlUp)).Select
Selection.Merge
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(1, 0).Select
Loop
 ActiveCell.Offset(0, -5).Select
    ActiveCell.Offset(3, 0).Select
Loop
End If
ActiveCell.Offset(5, 0).Select
Loop

Ich weiss nicht genau wieso das selection.merge auch drin ist, aber das verursacht möglicherweise den Absturz.
für jegliche Hilfe bin ich sehr dankbar
Beste Grüsse
Corsin

Bild

Betrifft: AW: Zellen einfügen mit Rahmenlinie per Makro
von: fcs
Geschrieben am: 05.05.2015 15:49:41
Hallo Corsin,
der Kollege hat scheinbar irgendwie versucht, zwischen den Linien und dem Text einen Abstand zu erzeugen, um die Lesbarkeit zu verbessern.
Warum da Makro an 150 Zeilen mit zu verbindenden Zellen scheitert - ich weiss es nicht.
Ich würde an deiner Stelle die Formatierungen anders lösen.
z.B. Text in den Zellen vertikal zentrieren und Zeilenhöhe der einzelnen Zeilen vergrößern.
Auf die verbundenen Zellen würde ich ganz verzichten.
Gruß
Franz

Sub Zeilen_Formatieren()
    Dim wks As Worksheet
    Dim Zeile_1 As Long, Zeile_L As Long, Zeile As Long
    Dim Spalte_1 As Long, Spalte_L As Long
    Dim rngFormat As Range
    
    Set wks = Sheets("Referenzliste")
    
    Zeile_1 = 5 '1. zu formatierende Zeile
    Spalte_1 = 2 'Spalte B - 1. zu formatierende Spalte
    Spalte_L = 7 'Spalte G - Letzte zu formatierende Spalte
    
    With wks
      .Activate
      Application.ScreenUpdating = False
      'letzte Datenzeile in 1. Spalte ermitteln
      Zeile_L = .Cells(.Rows.Count, Spalte_1).End(xlUp).Row
      
      'zu formatiernder Zellbereich
      Set rngFormat = .Range(.Cells(Zeile_1, Spalte_1), .Cells(Zeile_L, Spalte_L))
      
      With rngFormat
          'Alle Linienformate zurücksetzen
          .Borders.LineStyle = xlLineStyleNone
          'horizontale Haarlinien oben/unten/zwischen den Zellen
          With .Borders(xlInsideHorizontal)
              .LineStyle = xlContinuous
              .ColorIndex = xlAutomatic
              .TintAndShade = 0
              .Weight = xlHairline
          End With
          With .Borders(xlEdgeTop)
              .LineStyle = xlContinuous
              .ColorIndex = xlAutomatic
              .TintAndShade = 0
              .Weight = xlHairline
          End With
          With .Borders(xlEdgeBottom)
              .LineStyle = xlContinuous
              .ColorIndex = xlAutomatic
              .TintAndShade = 0
              .Weight = xlHairline
          End With
          'Zeilenhöhe automatisch
          .EntireRow.AutoFit
          'Vertikale Ausrichtung zentrieren
          .VerticalAlignment = xlCenter
      End With
      'in allen Zeilen die Zeilenhöhe um 6 erhöhen
      For Zeile = Zeile_1 To Zeile_L
        With .Rows(Zeile)
          .RowHeight = .RowHeight + 6
          End With
      Next
    End With
    Application.ScreenUpdating = True
End Sub


Bild

Betrifft: AW: Zellen einfügen mit Rahmenlinie per Makro
von: corsin cathomen
Geschrieben am: 06.05.2015 08:55:33
Hallo Franz
Ich danke Dir vielmals für deine Hilfe.
Wenn ich dein Makro verwende hat es den Vorteil, dass die allgemeine Formatierung besser aussieht! Danke dafür :-)
Leider wird aber nun eine Haarlinie bei jeder Zelle erstellt. Da aber parallel über ein anderes Makro noch Überschriften und Spaltenbeschriftungen pro Bereich erstellt werden, sind nun diverse Haarlinien an Orten wo sie nichts zu suchen haben :-)
Ich habe mal ein Bild beigelegt wo du den Unterschied siehts.
Userbild
Besten Dank
Gruss
Corsin

Bild

Betrifft: AW: Zellen einfügen mit Rahmenlinie per Makro
von: fcs
Geschrieben am: 06.05.2015 09:51:20
Hallo Corsin,
ich hab das Makro jetzt etwas angepaßt.
Es werden jetzt die Inhalte in Spalte B/C geprüft und abhängig davon Linienformate gesetzt.
Falls es noch nicht klappt, dann solltest du eine kleine Beispieldatei hier hochladen, statt eines Bildes. Dann kann man auch in Excel vernünftig am realen Objekt testen.
Gruß
Franz

Sub Zeilen_Formatieren()
    Dim wks As Worksheet
    Dim Zeile_1 As Long, Zeile_L As Long, Zeile As Long
    Dim Spalte_1 As Long, Spalte_L As Long
    Dim rngFormat As Range
    Dim bolLinie As Boolean
    
    Set wks = Sheets("Referenzliste")
    
    Zeile_1 = 5 '1. zu formatierende Zeile
    Spalte_1 = 2 'Spalte B - 1. zu formatierende Spalte
    Spalte_L = 7 'Spalte G - Letzte zu formatierende Spalte
    
    With wks
      .Activate
      Application.ScreenUpdating = False
      'letzte Datenzeile in 1. Spalte ermitteln
      Zeile_L = .Cells(.Rows.Count, Spalte_1).End(xlUp).Row
      
      'zu formatiernder Zellbereich
      Set rngFormat = .Range(.Cells(Zeile_1, Spalte_1), .Cells(Zeile_L, Spalte_L))
      
      With rngFormat
          'Alle Linienformate zurücksetzen
          .Borders.LineStyle = xlLineStyleNone
          'Zeilenhöhe automatisch
          .EntireRow.AutoFit
          'Vertikale Ausrichtung zentriert
          .VerticalAlignment = xlCenter
      End With
      
      'in allen Zeilen die Zeilenhöhe um 6 erhöhen, Inhalte prüfen, ggf. Linie-Oben
      For Zeile = Zeile_1 To Zeile_L
        With .Rows(Zeile)
          .RowHeight = .RowHeight + 6
        End With
        If .Cells(Zeile, Spalte_1) = "" And .Cells(Zeile, Spalte_1 + 1) = "" Then
          'bei leerer Zeile Formatieren von Linie-Oben deaktivieren
          bolLinie = False
        ElseIf LCase(Left(.Cells(Zeile, Spalte_1).Text, 7)) = "objekt," Then
          'bei Zeile mit "OBJEKT,....." Formatieren von Linie-Oben aktivieren
          bolLinie = True
        ElseIf .Cells(Zeile, Spalte_1) <> "" And bolLinie = True Then
          'Haarlinie oben wenn Zelle mit Inhalt und Formatieren Linie-Oben aktiv
          Set rngFormat = .Range(.Cells(Zeile, Spalte_1), .Cells(Zeile, Spalte_L))
          With rngFormat.Borders(xlEdgeTop)
              .LineStyle = xlContinuous
              .ColorIndex = xlAutomatic
              .TintAndShade = 0
              .Weight = xlHairline
          End With
        End If
      Next
    End With
    Application.ScreenUpdating = True
End Sub


Bild

Betrifft: AW: Zellen einfügen mit Rahmenlinie per Makro
von: corsin cathomen
Geschrieben am: 06.05.2015 10:37:40
Hallo Franz
Du bist ja flott mit antworten. Besten Dank!
Deine Prüfung die du eingebaut hast funktioniert.
Ausser beim 1. Bereich Projektmanagement klappt es nicht. Aber keine Ahnung wieso nicht. In diesem Bereich werden gar keine Linien gesetzt. Bei allen anderen schon.
Um die Datei hier hochzuladen müsste ich sie noch entschärfen. Hast du eine Erklärung warum es beim ersten Bereich nicht klappen könnte?
Falls nötig werde ich gerne die Datei bereitstellen.
Vielen Dank & Beste Grüsse
Corsin

Bild

Betrifft: AW: Zellen einfügen mit Rahmenlinie per Makro
von: fcs
Geschrieben am: 06.05.2015 11:41:40
Hallo Corsin,
passe in der folgende Zeile die Zeilennummer 5 an:

    Zeile_1 = 5 '1. zu formatierende Zeile

Dies muss die 1. Zeile sein, in der in Spalte B der Eintrag "OBJEKT, BAUSUMME" steht.
Also wahrscheinlich 4.
Gruß
Franz

Bild

Betrifft: AW: Zellen einfügen mit Rahmenlinie per Makro
von: corsin cathomen
Geschrieben am: 06.05.2015 12:11:19
Bingo! Perfekt! Funktioniert nun einwandfrei.
Vielen tausend Dank für die Erstellung des Makros!
Ich wünsch dir einen schönen Tag
Gruss
Corsin

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Zellen einfügen mit Rahmenlinie per Makro "