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