Spaltenrahmen ändern

[Icepic]

Hallo zusammen von hier werden Sie geholfen.

Dies hat bisher gut geklappt. Vielleicht könnt Ihr mir auch dahingehend helfen.

In der Anwendung , an der ich arbeite kopiere ich die Spalte B jeweils 1mal bis
12 Spalten erreicht sind. Hierbei hat mich Andre aus G in T unterstützt.

Jetzt stehe ich vor der Problematik, dass ich den rechten und linken Rahmen anpassen
muss. Dies erledige ich mit diesen Befehlsfolgen.

        'Rahmen recht- und linksseitig ergänzen
        Range("C4:C10,C12:C18,C20:C26").Borders(xlEdgeRight).LineStyle = xlContinuos
        Range("C4:C10,C12:C18,C20:C26").Borders(xlEdgeRight).Weight = xlThin
        Range("C4:C10,C12:C18,C20:C26").Borders(xlEdgeLeft).LineStyle = xlContinuos
        Range("C4:C10,C12:C18,C20:C26").Borders(xlEdgeLeft).Weight = xlThin
        'Rahmen Farbe blau
        Range("C20:C26").Borders(xlEdgeRight).Color = -4165632
        Range("C20:C26").Borders(xlEdgeRight).Color = -4165632

Dies gilt natürlich nur für die Spalte C. Beim nächsten Durchlauf des Macros müsste hier
dann Range("D4:D10,D12:D18,D20:D26") stehen.

Hat jemand hierzu eine Idee?

Gruß aus Hamburg

Michael

P.S. Warum mir in der Vorschau für 'Doppelpunkt D' Smilies angezeigt werden bleibt mir verborgen.

[WillWissen]

Hi Michael,

Warum mir in der Vorschau für 'Doppelpunkt D' Smilies angezeigt werden bleibt mir verborgen.

Doppelpunkt & D ist ein lachendes Smilie und das bekommst du zu sehen, wenn du diese nicht deaktivierst. Wann immer du eine Formel postest, die ein Smilie hervorruft, solltest du diese ausschalten. Dann werden dir allerdings auch gewollte nicht mehr angezeigt. Hier findest du die Einstellung:

[
Bild bitte so als Datei hochladen: Klick mich!
]

[Icepic]

Danke Gunter, habe ich verstanden.

Mein vorrangiges Problem in der obigen Beschreibung habe ich erst mal über ein Select Case gelöst.
Die bläht mir jedoch den Code sehr auf. Wenn jemand eine besserer Idee hat bitte melden.

Gruß aus Hamburg

Michael

[Kuwer]

Hallo Michael,

Option Explicit

Sub Neue_Spalte_anlegen()
   'Variablendeklaration
   Dim iMax As Integer
   'Maximalwert aus Zeile 4 uebernehmen
   iMax = WorksheetFunction.Max(Range("B4:M4"))
   'Max. Anzahl Spalten erreicht ?
   If iMax >= 12 Then
       'Sheets("Übersicht").Shapes.Range(Array("Schaltfläche 1")).Font.ColorIndex = 3
       MsgBox "Max. Anzahl erreicht!", vbOKOnly, "Systemmeldung"
       Exit Sub
   End If
   'Anlegen neues Tabellenblatt
   Sheets("Muster").Copy After:=Sheets(Sheets.Count)
   'Rename neues Tabellenblatt
   Sheets(Sheets.Count).Name = "Firma " & iMax + 1
   'Zurueck nach Blatt Uebersicht
   Sheets("Übersicht").Activate
   'Mit Spalte C versetzt um imax-1
   With Range("B4").Offset(0, iMax)
       'Spalte B kopieren
       Range("B4:B26").Copy .Cells(1)
       'Firmennummer eintragen
       .Value = iMax + 1
       With Application.Intersect(Range("B4:B10,B12:B18,B20:B26").EntireRow, .EntireColumn)
         'in eingefuegten Formeln Firma 1 durch Firma + iMax ersetzen
         .Replace What:="Firma 1", Replacement:="Firma " & iMax + 1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         'Rahmen recht- und linksseitig ergänzen
         .Borders(xlEdgeLeft).LineStyle = xlContinuous
         .Borders(xlEdgeLeft).Weight = xlThin
         .Borders(xlEdgeRight).LineStyle = xlContinuous
         .Borders(xlEdgeRight).Weight = xlThin
       End With
       'Neu angelegtes Kontrollblatt aktivieren
       'Sheets("Firma " & iMax + 1).Activate
       'Sheets("Firma " & iMax + 1).Range("A1").Select
       'Ende Mit Spalte C versetzt um imax-1
   End With
End Sub

Code eingefügt mit: Excel Code Jeanie

Gruß Uwe

[Icepic]

Danke Uwe,

das hat mir sehr geholfen. In Range("B20:B26") muss der Rahmen jedoch blau sein.

Wie kann das auch noch eingebaut werden ?

Gruß aus Hamburg

Michael

[Kuwer]

Hallo Michael,

In Range("B20:B26") muss der Rahmen jedoch blau sein.

in Deiner Beispieldatei ist er blau und bleibt blau.

Gruß Uwe

[Kuwer]

Option Explicit

Sub Neue_Spalte_anlegen()
   'Variablendeklaration
   Dim iMax As Integer
   'Maximalwert aus Zeile 4 uebernehmen
   iMax = WorksheetFunction.Max(Range("B4:M4"))
   'Max. Anzahl Spalten erreicht ?
   If iMax >= 12 Then
       'Sheets("Übersicht").Shapes.Range(Array("Schaltfläche 1")).Font.ColorIndex = 3
       MsgBox "Max. Anzahl erreicht!", vbOKOnly, "Systemmeldung"
       Exit Sub
   End If
   'Anlegen neues Tabellenblatt
   Sheets("Muster").Copy After:=Sheets(Sheets.Count)
   'Rename neues Tabellenblatt
   Sheets(Sheets.Count).Name = "Firma " & iMax + 1
   'Zurueck nach Blatt Uebersicht
   Sheets("Übersicht").Activate
   'Mit Spalte B versetzt um imax-1
   With Range("B4").Offset(0, iMax)
       'Spalte B kopieren
       Range("B4:B26").Copy .Cells(1)
       'Firmennummer eintragen
       .Value = iMax + 1
       With Application.Intersect(Range("B4:B10,B12:B18,B20:B26").EntireRow, .EntireColumn)
         'in eingefuegten Formeln Firma 1 durch Firma + iMax ersetzen
         .Replace What:="Firma 1", Replacement:="Firma " & iMax + 1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         'Rahmen recht- und linksseitig ergänzen
         .Borders(xlEdgeLeft).LineStyle = xlContinuous
         .Borders(xlEdgeLeft).Weight = xlThin
         If iMax < 11 Then
           .Borders(xlEdgeRight).LineStyle = xlContinuous
           .Borders(xlEdgeRight).Weight = xlThin
         End If
       End With
       'Selection aufheben
       ActiveSheet.EnableSelection = xlNoSelection
       'Kopiermodus ausschalten
       Application.CutCopyMode = False
       'Neu angelegtes Kontrollblatt aktivieren
       'Sheets("Firma " & iMax + 1).Activate
       'Sheets("Firma " & iMax + 1).Range("A1").Select
       'Ende Mit Spalte C versetzt um imax-1
   End With
End Sub

Gruß Uwe