Makro ausführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
ich möchte den nutzern meines Fs-Planers (Kalender) ermöglichen für bestimmte bereiche eigene Hintergrundfarben bzw Schriftfarben festzulegen. Da dies stellenweise Datumsabhängig (zB.: Ferien) ist möchte ich jeweils nur eine zelle so formatieren lassen und anschließend über ein extra makro das ganze ändern. Ursprünglich wollte ich ja eine UF aufrufen und hier eine Farbpalette anzeigen lassen und nach Farbwahl folgende Befehle bzw Makros ausführen lassen:
Worksheets("FS-Planer").[a6:c36, f6:h36, k6:m36, p6:r36, u6:w36, z6:ab36, ae6:ag36, Aj6:Al36, Ao6:Aq36, At6:Av36, Ay6:Ba36, Bd6:Bf36].Interior.ColorIndex = [DatumFarbe1].Interior.ColorIndex


Sub FerienSep_ein()
Dim f As Integer
Dim Anfang As Date
Dim Ende As Date
For f = 530 To 534
Anfang = Worksheets("Fs-Planer").Cells(f, 23)
Ende = Worksheets("Fs-Planer").Cells(f, 24)
For z = 6 To 36 ' =Zeilen 6 bis 36
For s = 1 To 60 Step 5 '=Spalten A, E, E, ... , AS
If Cells(z, s) >= Anfang And Cells(z, s)


Sub Sonntage_Rot()     'Hier die Sonntage rot gefärbt
For z = 6 To 36 ' =Zeilen 6 bis 36
For s = 1 To 60 Step 5 '=Spalten A, E, E, ... , AS
If Weekday(Cells(z, s).Value) = vbSunday Then
Range(Cells(z, s), Cells(z, s + 2)).Font.ColorIndex = [FarbeSoFe].Font.ColorIndex
End If
Next s
Next z
End Sub

'***************************************************************************************'
'Hier werden bezahlte gesetzliche bzw kirchliche Feiertage eingetragen (Rheinland-Pfalz)'
'***************************************************************************************'


Sub Kommentar()
On Error Resume Next 'gibt Fehler wenn kein Kommentar vorhanden
With Worksheets("FS-Planer")
Set Bereich = Application.Union(.Range("c6:c36"), .Range("h6:h36"), .Range("m6:m36"), _
.Range("r6:r36"), .Range("w6:w36"), .Range("ab6:ab36"), .Range("ag6:ag36"), .Range("al6:al36") _
, .Range("aq6:aq36"), _
.Range("av6:av36"), .Range("ba6:ba36"), .Range("bf6:bf36"))
Bereich.SpecialCells(xlCellTypeComments).ClearComments
For n = 101 To 113
z = 5 + Day(Worksheets("Fs-Planer").Cells(n, 1))
s = (Month(Worksheets("Fs-Planer").Cells(n, 1)) - 1) * 5 + 3
.Cells(z, s).AddComment
.Cells(z, s).Comment.Visible = False
.Cells(z, s).Comment.Text Text:=Worksheets("Fs-Planer").Cells(n, 2).Value
.Cells(z, s).Font.ColorIndex = [FarbeSoFe].Font.ColorIndex
.Cells(z, s - 1).Font.ColorIndex = [FarbeSoFe].Font.ColorIndex
.Cells(z, s - 2).Font.ColorIndex = [FarbeSoFe].Font.ColorIndex
Next n
End With
End Sub

Das krieg ich aber nicht gebacken,
Gruß Hans

Option Explicit Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (lpcc As CHOOSECOLOR_TYPE) As Long Type CHOOSECOLOR_TYPE lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As Long Flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Enum CC_ZusatzEinstellungen CC_AlleFarben = &H100 CC_AlleFarbenAnzeigen = &H2 CC_KeinErweitern = &H1 CC_StandardFarbe = &H1 CC_HilfeAnzeigen = &H1 CC_NurGrundfarben = &H80 End Enum Type FarbAuswahlInfo VordefinierteFarben(15) As Long Vorauswahl As Long ZusatzEinstellungen As CC_ZusatzEinstellungen End Type Function FarbAuswahl(Info As FarbAuswahlInfo) As Long Dim ccColor As CHOOSECOLOR_TYPE Dim Farben(15) As Long With ccColor .lStructSize = Len(ccColor) .hwndOwner = Application.Hwnd .hInstance = Application.hInstance .rgbResult = Info.Vorauswahl .lpCustColors = VarPtr(Info.VordefinierteFarben(0)) .Flags = Info.ZusatzEinstellungen .lpfnHook = 0& End With ChooseColor ccColor FarbAuswahl = ccColor.rgbResult End Function Function Infos() As FarbAuswahlInfo With Infos .VordefinierteFarben(0) = RGB(255, 0, 0) .VordefinierteFarben(1) = RGB(0, 255, 0) .VordefinierteFarben(2) = RGB(0, 0, 255) .VordefinierteFarben(3) = RGB(255, 255, 0) .VordefinierteFarben(4) = RGB(0, 255, 255) .VordefinierteFarben(5) = RGB(255, 0, 255) .VordefinierteFarben(6) = RGB(255, 255, 255) .VordefinierteFarben(7) = RGB(128, 0, 0) .VordefinierteFarben(8) = RGB(0, 128, 0) .VordefinierteFarben(9) = RGB(0, 0, 128) .VordefinierteFarben(10) = RGB(128, 128, 0) .VordefinierteFarben(11) = RGB(0, 128, 128) .VordefinierteFarben(12) = RGB(128, 0, 128) .VordefinierteFarben(13) = RGB(128, 128, 128) .VordefinierteFarben(14) = RGB(255, 128, 0) .VordefinierteFarben(15) = RGB(0, 128, 255) .Vorauswahl = RGB(255, 0, 0) .ZusatzEinstellungen = CC_AlleFarben Or CC_StandardFarbe Or CC_HilfeAnzeigen Or CC_KeinErweitern End With End Function Sub AnderesMakro(iFarbe As Long) 'Hilfsmakro Beispiel Range("A1").Interior.ColorIndex = iFarbe Range("A3").Interior.ColorIndex = iFarbe Range("A5").Interior.ColorIndex = iFarbe End Sub Sub StartMakro() 'Start Makro Dim iFarbe As Long iFarbe = FarbAuswahl(Infos) Call AnderesMakro(iFarbe) End Sub

Option Explicit Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (lpcc As CHOOSECOLOR_TYPE) As Long Type CHOOSECOLOR_TYPE lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As Long Flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Enum CC_ZusatzEinstellungen CC_AlleFarben = &H100 CC_AlleFarbenAnzeigen = &H2 CC_KeinErweitern = &H1 CC_StandardFarbe = &H1 CC_HilfeAnzeigen = &H1 CC_NurGrundfarben = &H80 End Enum Type FarbAuswahlInfo VordefinierteFarben(15) As Long Vorauswahl As Long ZusatzEinstellungen As CC_ZusatzEinstellungen End Type Function FarbAuswahl(Info As FarbAuswahlInfo) As Long Dim ccColor As CHOOSECOLOR_TYPE Dim Farben(15) As Long With ccColor .lStructSize = Len(ccColor) .hwndOwner = Application.Hwnd .hInstance = Application.hInstance .rgbResult = Info.Vorauswahl .lpCustColors = VarPtr(Info.VordefinierteFarben(0)) .Flags = Info.ZusatzEinstellungen .lpfnHook = 0& End With ChooseColor ccColor FarbAuswahl = ccColor.rgbResult End Function Function Infos() As FarbAuswahlInfo With Infos .VordefinierteFarben(0) = RGB(255, 0, 0) .VordefinierteFarben(1) = RGB(0, 255, 0) .VordefinierteFarben(2) = RGB(0, 0, 255) .VordefinierteFarben(3) = RGB(255, 255, 0) .VordefinierteFarben(4) = RGB(0, 255, 255) .VordefinierteFarben(5) = RGB(255, 0, 255) .VordefinierteFarben(6) = RGB(255, 255, 255) .VordefinierteFarben(7) = RGB(128, 0, 0) .VordefinierteFarben(8) = RGB(0, 128, 0) .VordefinierteFarben(9) = RGB(0, 0, 128) .VordefinierteFarben(10) = RGB(128, 128, 0) .VordefinierteFarben(11) = RGB(0, 128, 128) .VordefinierteFarben(12) = RGB(128, 0, 128) .VordefinierteFarben(13) = RGB(128, 128, 128) .VordefinierteFarben(14) = RGB(255, 128, 0) .VordefinierteFarben(15) = RGB(0, 128, 255) .Vorauswahl = RGB(255, 0, 0) .ZusatzEinstellungen = CC_AlleFarben Or CC_StandardFarbe Or CC_HilfeAnzeigen Or CC_KeinErweitern End With End Function Sub AnderesMakro(iFarbe As Long) 'Hilfsmakro Beispiel Range("A1").Interior.Color = iFarbe Range("A3").Interior.Color = iFarbe Range("A5").Interior.Color = iFarbe End Sub Sub StartMakro() 'Start Makro Dim iFarbe As Long iFarbe = FarbAuswahl(Infos) Call AnderesMakro(iFarbe) End Sub

Option Explicit Function ColorFromPallet(Optional lOldCol As Double = xlNone) As Double Dim dSavCol As Double, dNewCol As Double Dim iRGB_R As Integer, iRGB_G As Integer, iRGB_B As Integer dSavCol = ActiveWorkbook.Colors(32) If lOldCol = xlNone Then ColIx2RGB 13160660, iRGB_R, iRGB_G, iRGB_B Else ColIx2RGB lOldCol, iRGB_R, iRGB_G, iRGB_B End If If Application.Dialogs(xlDialogEditColor).Show _ (32, iRGB_R, iRGB_G, iRGB_B) Then ColorFromPallet = ActiveWorkbook.Colors(32) ActiveWorkbook.Colors(32) = dSavCol Else ColorFromPallet = lOldCol End If End Function Sub ColIx2RGB(ByVal lCol As Long, iR As Integer, iG As Integer, iB As Integer) iR = lCol Mod 256: lCol = lCol \ 256 iG = lCol Mod 256: lCol = lCol \ 256 iB = lCol Mod 256 End Sub Sub AnderesMakro(iFarbe As Long) 'Hilfsmakro Beispiel Range("A1").Interior.Color = iFarbe Range("A3").Interior.Color = iFarbe Range("A5").Interior.Color = iFarbe End Sub Sub StartMakro() 'Start Makro Dim iFarbe As Long iFarbe = ColorFromPallet() Call AnderesMakro(iFarbe) End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread