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.
Hi Michael,
Zitat: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!]
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
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
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
Hallo Michael,
(20.11.2016, 18:04)Icepic schrieb: [ -> ]In Range("B20:B26") muss der Rahmen jedoch blau sein.
in Deiner Beispieldatei ist er blau und bleibt blau.
Gruß Uwe
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