habe eine Aufgabe für Euch:
Ich würde gerne in meinem Jahreskalender, dass die Kalenderwoche graphisch (Wordart)
und in der Mitte der Woche angezeigt wird.
Vielen Dank im voraus.
Viele Grüße
Frieder
Option Explicit
Sub test()
Dim objShp As Shape, rng As Range
For Each objShp In ActiveSheet.Shapes
If objShp.Name Like "KW*" Then objShp.Delete
Next
For Each rng In Range("A1:L31")
If IsDate(rng) Then
If Weekday(rng, vbMonday) = 4 Then
Call createWordArt(rng, DINKwoche(rng))
End If
End If
Next
End Sub
Sub createWordArt(Target As Range, Text As String)
Dim objWA As Shape
Set objWA = Target.Parent.Shapes.AddTextEffect(msoTextEffect36, Text, "KW_" & Text, 28, msoFalse, msoFalse, 0, 0)
With objWA
.Name = "KW_" & Text
With .TextFrame2
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.MarginBottom = 0
.AutoSize = msoAutoSizeShapeToFitText
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
With .TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(155, 155, 155)
.Transparency = 0.5
End With
End With
.Left = Target.Left + Target.Width / 2 - .Width / 2
.Top = Target.Top + Target.Height / 2 - .Height / 2
.OnAction = "dummy"
End With
Set objWA = Nothing
End Sub
Private Sub dummy()
End Sub
Private Function DINKwoche(ByVal Datum As Date) As Long
Dim tmp As Date
tmp = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKwoche = (Fix(Datum - tmp - 3 + (Weekday(tmp) + 1) Mod 7) \ 7) + 1
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0
A | B | C | D | E | F | |
1 | Gruß Sepp | |||||
2 | ||||||
3 |
A | B | C | D | E | F | |
1 | Gruß Sepp | |||||
2 | ||||||
3 |
A | B | C | D | E | F | |
1 | Gruß Sepp | |||||
2 | ||||||
3 |
A | B | C | D | E | F | |
1 | Gruß Sepp | |||||
2 | ||||||
3 |
A | B | C | D | E | F | |
1 | Gruß Sepp | |||||
2 | ||||||
3 |
Sub test()
Dim objShp As Shape, rng As Range
For Each objShp In ActiveSheet.Shapes
If objShp.Name Like "KW*" Then objShp.Delete
Next
For Each rng In Range("B3:B95,F2:F95,J2:J95,N2:N95,R2:R95") 'hier noch die Spalten _
erweitern!
If IsDate(rng) Then
If Weekday(rng, vbMonday) = 3 Then
Call createWordArt(rng(2).Offset(, 2), DINKwoche(rng))
End If
End If
Next
End Sub
Gruß Matthias Call createWordArt(rng, "KW " & DINKwoche(rng))
Gruß Matthias'...
With objWA
.Name = "KW_" & Text
.IncrementRotation 45
Option Explicit
Sub insertWeekNum()
Dim objShp As Shape, lngRow As Long, lngCol As Long
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
With Sheets("Jahreskalender")
For Each objShp In .Shapes
If objShp.Name Like "KW*" Then objShp.Delete
Next
For lngCol = 1 To 45 Step 4
For lngRow = 3 To 94
If IsDate(.Cells(lngRow, lngCol)) Then
If Weekday(.Cells(lngRow, lngCol), vbMonday) = 4 Then
Call createWordArt(.Cells(lngRow + 1, lngCol + 3), Format(DINKwoche(.Cells(lngRow, lngCol)), """KW ""00"))
End If
End If
Next
Next
End With
ErrorHandler:
Application.ScreenUpdating = True
End Sub
Private Sub createWordArt(Target As Range, Text As String)
Dim objWA As Shape
Set objWA = Target.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 16, 16)
With objWA
.Name = "KW_" & Text
.Rotation = 45
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
With .TextFrame2
.TextRange.Characters.Text = Text
With .TextRange.Font
.Size = 42
.Line.Visible = msoFalse
With .Fill
.Solid
.Visible = msoTrue
.ForeColor.RGB = vbBlack
.Transparency = 0.8
End With
End With
.WordWrap = msoFalse
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.MarginBottom = 0
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
.AutoSize = msoAutoSizeShapeToFitText
End With
.Left = Target.Left + Target.Width / 2 - .Width + 25
.Top = Target.Top + Target.Height / 2 - .Height / 2
If Target.Row = 4 Then .Top = Target.Top
If Target.Row = 94 Then .Top = Target.Offset(-2, 0).Top
.OnAction = "dummy"
End With
Set objWA = Nothing
End Sub
Private Sub dummy()
End Sub
Private Function DINKwoche(ByVal Datum As Date) As Long
Dim tmp As Date
tmp = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKwoche = (Fix(Datum - tmp - 3 + (Weekday(tmp) + 1) Mod 7) \ 7) + 1
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0
A | B | C | D | E | F | |
1 | Gruß Sepp | |||||
2 | ||||||
3 |