01. oktober 2012 - 14:58Der er
2 kommentarer og 1 løsning
Fast markering på graf
I en graf (bar chart) har jeg samtlige uger på et år, der er forskellige værdier pr uge (timeantal). Jeg ville gerne kunne markere den uge hvori månedsskiftet ligger - evt. blot ved at værdien (barren om man vil) skiftede farve i ca hver 5 uge.
Jeg har forsøgt med at indlægge en fast værdi imellem to uger, men det bliver lige gnidret nok.
Dim dag1 As Date, denFørsteUgedag, aktuelleUgeNr, årx, dagx As Date Dim antalUger As Integer, ugeNr As Integer, mdX As Integer Private Sub Worksheet_Activate() ActiveSheet.ChartObjects("Chart 4").Activate antalUger = ActiveChart.SeriesCollection(1).Points.Count aktuelleUgeNr = Format(Now, "ww", 2, 2)
For ugeNr = 1 To aktuelleUgeNr dagx = denFørsteDagIugen(ugeNr) mdX = Month(dagx)
If Month(DateAdd("d", 6, dagx)) <> mdX Then ActiveChart.SeriesCollection(1).Points(ugeNr).Select Selection.Interior.ColorIndex = 6 End If Next ugeNr End Sub Public Function denFørsteDagIugen(uge) Dim dag1 As Date, denFørsteUgedag, ugeNr, årx, dagx As Date dag1 = "01-01-" & CStr(Year(Now)) denFørsteUgedag = Format(dag1, "w", 2, 2) ugeNr = Format(dag1, "ww", 2, 2)
Rem ryk frem til uge 1 - hvis den 1. uge ikke er 1 If ugeNr <> "1" Then While Format(dag1, "ww", 2, 2) <> "1" dag1 = DateAdd("d", 1, dag1) Wend Else If denFørsteUgedag <> 1 Then dag1 = DateAdd("d", (Val(denFørsteUgedag) - 1) * -1, dag1) End If End If
If uge <> "1" Then dag1 = DateAdd("ww", Val(uge) - 1, dag1) End If
En stor tak til Supertekst-it, der endda var flink at svare på opfølgende spørgsmål.
Den komplette løsning endte således: Dim dag1 As Date, denFørsteUgedag, aktuelleUgeNr, årx, dagx As Date Dim antalUger As Integer, ugeNr As Integer, mdX As Integer Dim startUge As Integer, slutUge As Integer Dim dia, diagramNavn Public Sub marker_sidste_uge_i_måneden() startUge = Range("B1") slutUge = findSidsteUge
For Each dia In ActiveSheet.ChartObjects diagramNavn = dia.Name markerEtDiagram diagramNavn Next dia End Sub Public Sub fjern_markering() startUge = Range("B1") slutUge = findSidsteUge
For Each dia In ActiveSheet.ChartObjects diagramNavn = dia.Name ActiveSheet.ChartObjects(diagramNavn).Activate ActiveChart.SeriesCollection(1).Select With Selection.Format.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent5 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With Next dia End Sub Public Function findSidsteUge() For k = 1 To ActiveCell.SpecialCells(xlLastCell).Column If Cells(1, k) = "" Then findSidsteUge = Cells(1, k - 1) Exit Function End If Next k End Function Public Sub markerEtDiagram(diagramNavn) ActiveSheet.ChartObjects(diagramNavn).Activate
For ugeNr = startUge To slutUge dagx = denFørsteDagIugen(ugeNr) mdX = Month(dagx)
If Month(DateAdd("d", 7, dagx)) <> mdX Then ActiveChart.SeriesCollection(1).Points(ugeNr - startUge + 1).Select Selection.Interior.ColorIndex = 6 End If Next ugeNr End Sub Public Function denFørsteDagIugen(uge) Dim dag1 As Date, denFørsteUgedag, ugeNr, årx, dagx As Date dag1 = "01-01-" & CStr(Year(Now)) denFørsteUgedag = Format(dag1, "w", 2, 2) ugeNr = Format(dag1, "ww", 2, 2)
Rem ryk frem til uge 1 - hvis den 1. uge ikke er 1 If ugeNr <> "1" Then While Format(dag1, "ww", 2, 2) <> "1" dag1 = DateAdd("d", 1, dag1) Wend Else If denFørsteUgedag <> 1 Then dag1 = DateAdd("d", (Val(denFørsteUgedag) - 1) * -1, dag1) End If End If
If uge <> "1" Then dag1 = DateAdd("ww", Val(uge) - 1, dag1) End If
denFørsteDagIugen = dag1 End Function
På denne måde har jeg både en fjern markering og en sæt markering på, som jeg i praksis lavede til to knapper på arket.
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.