AW: einfach den Code umstellen ...
29.10.2018 17:45:31
Sepp
Hallo Frieder,
hier der Code mit den entsprechenden Anpassungen.
Modul Modul1
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
