Avatar billede kim1a Ekspert
01. oktober 2012 - 14:58 Der 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.
Avatar billede supertekst Ekspert
01. oktober 2012 - 15:34 #1
En VBA-kode kunne måske være en mulighed.

Kunne du sende en kopi/model af filen? @-adresse under min profil.
Avatar billede supertekst Ekspert
02. oktober 2012 - 15:13 #2
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
   
    denFørsteDagIugen = dag1
End Function
Avatar billede kim1a Ekspert
19. oktober 2012 - 14:37 #3
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
   
    antalUger = ActiveChart.SeriesCollection(1).Points.Count
    aktuelleUgeNr = Format(Now, "ww", 2, 2)
   
    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.
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester