Automatisk opdatering/udbygning af grafområde og farvning af graf

Hej Dennisa.
Hvis du stadig søger hjælp på ovenstående så giv lige i pip, så kan jeg godt skrive et svar til dig. Da jeg ligger i byggerod - kan der godt gå en 4-5 dage.

Michael

Hej Michael

Arbejdshastigheden er ok !

Jag har ikke fundet nogen løsning endnu

Jeg finder et svar :-)

Michael

Det ville nok være det nemmeste for mig, hvis du lige sendte Excelmappen.
Kan du gøre det ?
m.koppelgaard@gmail.com
Michael

Hej Michael

Jeg har ikke noget regneark endnu, så der er frit slag i bolledejen :-)

Fedt udtryk !
Men det jeg lige manglede at vide var, om det er A,B,C... der skal være på x-aksen og kp1, kp2 som skal være på på forklaringsteksten.

Endvidere :
Jeg kunne forstille mig, at du vil have grafen til at opdatere automatisk, som følge af tilføjelse af ekstra rækker eller kolonner - er det ikke rigtigt?

Ja, det er A, B, C ... som skal på X og KPI resultaterne på Y.

Modellen skulle i sin endelige form kunne honorere følgende arbejdsgang :

1. Data udtrækkes fra en given datakilde hvor flere ID / resultater indgår.
2. Slutbruger angiver hvilke ID/resultater der skal visualiseres i en form for stamdataark hvor ID, navn og titel er angivet.
3. Tabellen til brug for grafen opbygges som Lopslag mellem stamdata og data
4. Grafen opdateres med nye data / nye ID

Så du har ret i din endvidere :-)

Jeg havde forestillet mig, at set hele indbygges i en form for rapportgeneratorknap, hvro der skal være en hel masse programkode som aktiveres

Kan du følge mig ?

jeps

Hej Dinnisa

Her er min kode.
Koden skal lægges i det vindue, der komme frem, når du klikker på det aktuelle sheet(der hvor grafen er) og beder om "vis Programkode".

Const adr = "A1" henviser til øverste venstre hjørne af grafområdet (i ovenstående eksempel "ID")
A1 kan naturligvis ændres.

Jeg har IKKE brugt rødt til KAM data.,
Årsagen er at KP1,KP2,KP3 ... osv allerede lægger beslag på flere farver, og derfor er  det svært at vide, om rødt ikke på et eller andet tidspunkt vil blive taget i brug.
Jeg har derfor valgt at skravere søjlen, og bibeholde den farve, som søjlen i forvejen tildeles af Excel.

Det kan naturligvis ændres.

Jeg ville egentlig helst sende mit ark til dig, så ALLE misforståelser undgås.
Så hvis du har nogen problemer så læg lige din mailadresse - hvis du da ikke helst, vil holde den anonym..

Michael

Const adr = "A1"
Private Sub Worksheet_Change(ByVal Target As Range)
    formatGraf
End Sub
Sub formatGraf()

    Dim rng As Range, idRng As Range
    Dim cht As Chart
   
    Set cht = ActiveSheet.ChartObjects(1).Chart
    Set rng = Range(adr).CurrentRegion
    s = rng.Columns.Count - 2 'antal serier
    r = rng.Columns.Count - 1 'antalrækker
    r1 = rng(1).Row
    r2 = rng(1).Row + rng.Rows.Count - 1
    c1 = rng(1).Column
    c2 = rng(1).Column + rng.Columns.Count - 1
    Set idRng = Range(Cells(r1 + 1, c1), Cells(r2, c1))
   
    Do While cht.SeriesCollection.Count > 0
        cht.SeriesCollection(1).Delete
    Loop
    For serie = 1 To s
        cht.SeriesCollection.NewSeries
        cht.SeriesCollection(serie).Name = Cells(1, serie + 2).Value
        cht.SeriesCollection(serie).XValues = idRng
        cht.SeriesCollection(serie).Values = Range(Cells(r1 + 1, serie + 2), Cells(r2, serie + 2))
        For Each c In Range(Cells(r1 + 1, serie + 2), Cells(r2, serie + 2))
            punkt = c.Row - r1
            If Trim(UCase(Cells(c.Row, c1 + 1).Value)) = "KAM" Then cht.SeriesCollection(serie).Points(punkt).Fill.Patterned Pattern:=msoPatternWideUpwardDiagonal
        Next
   
    Next serie
   
End Sub

Hej Michael

Send gerne eksemplet :

DennisAPetersen@ofir.dk

ok

Virker overbevisende :-)

Jeg har besluttet mig for, udelukkende at benytte KPI1 i grafen, da det giver det pæneste/mest sigende resultat, derfor vil jeg kun have to farver ( rød/grøn ) til visualisering af KAM/AM, men jeg vil gerne have den specielle variant hvor der benyttes effekter i farven til at gøre søjlegrafen rund i udseende

Hvor retter jeg koden ?

Hej Dennisa
Her er tilrettet kode.

Jeg har sendt et ny ark til dig, med farveprøver.
Så kan du selv justere farve, som du ønsker.
Du skal rette i linierne:
If Trim(UCase(Cells(c.Row, c1 + 1).Value)) = "KAM" Then
                cht.SeriesCollection(serie).Points(punkt).Interior.ColorIndex = 3
            Else
                cht.SeriesCollection(serie).Points(punkt).Interior.ColorIndex = 41
end if

3(rød) og 41(blålig)kan ændres med til andre værdier mellem 1 og 50, som vist i arket.

Michael



Const adr = "A1"
Private Sub Worksheet_Change(ByVal Target As Range)
    formatGraf
End Sub
Sub formatGraf()

    Dim rng As Range, idRng As Range
    Dim cht As Chart
   
    Set cht = ActiveSheet.ChartObjects(1).Chart
    Set rng = Range(adr).CurrentRegion
    s = rng.Columns.Count - 2 'antal serier
    r = rng.Columns.Count - 1 'antalrækker
    r1 = rng(1).Row
    r2 = rng(1).Row + rng.Rows.Count - 1
    c1 = rng(1).Column
    c2 = rng(1).Column + rng.Columns.Count - 1
    Set idRng = Range(Cells(r1 + 1, c1), Cells(r2, c1))
   
    Do While cht.SeriesCollection.Count > 0
        cht.SeriesCollection(1).Delete
    Loop
    For serie = 1 To s
        cht.SeriesCollection.NewSeries
        cht.SeriesCollection(serie).Name = Cells(1, serie + 2).Value
        cht.SeriesCollection(serie).XValues = idRng
        cht.SeriesCollection(serie).Values = Range(Cells(r1 + 1, serie + 2), Cells(r2, serie + 2))
        For Each c In Range(Cells(r1 + 1, serie + 2), Cells(r2, serie + 2))
            punkt = c.Row - r1
            If Trim(UCase(Cells(c.Row, c1 + 1).Value)) = "KAM" Then
                cht.SeriesCollection(serie).Points(punkt).Interior.ColorIndex = 3
            Else
                cht.SeriesCollection(serie).Points(punkt).Interior.ColorIndex = 41
            End If
           
           
        Next
   
    Next serie
   
End Sub

Koden jeg har brugt til at vise far udfra index værdier er
Sub farvevalg()
    On Error Resume Next
    For Each c In Selection
        c.Offset(, 1).Interior.ColorIndex = c.Value
    Next 
End Sub

Du skrive blot en række heltal og markerer dem og sætter makroen i gang (F5).


Michael

Perfekt ....

For at gøre det superperfekt, har jeg alligevel besluttet at medtage KPI2, men som en udglattet kurve i helt gul ...

Kan du lige klare den også ???

mja jeg kan da prøve

Michael

Jeg har forsøgt at rette/omformattere den efterfølgende, men makroen fejler totalt

Hej Michael

Du får lige for god ordens skyld dine velfortjente point

Hej Dennisa jeg har ikke haft tid.
Sad netop nu og kikkede på det - er du ikke længere interesseret ??

Jeg er ikke gladn før du får et ordentligt produkt !!

Jo da :-)

Men du har jo reelt løst opgaven som den var defineret - men jo, jeg mangler lige den sidste detalje

Du får et svar lidt senere i formiddag.
Jeg hader, hvis det ikke bliver opgaven ikke er fuldført, så godt som muligt.

Michael

Kender det :-)

Hej Dinnisa
Jeg håber dette svarer til, hvad du ønsker.
Jeg har også sendt en fil.
Michael

Michael
Const adr = "A1"
Private Sub Worksheet_Change(ByVal Target As Range)
    formatGraf
End Sub
Sub formatGraf()

    Dim rng As Range, idRng As Range
    Dim cht As Chart
    On Error Resume Next
   
    Set cht = ActiveSheet.ChartObjects(1).Chart
    Set rng = Range(adr).CurrentRegion
    s = rng.Columns.Count - 2 'antal serier
    r = rng.Columns.Count - 1 'antalrækker
    r1 = rng(1).Row
    r2 = rng(1).Row + rng.Rows.Count - 1
    c1 = rng(1).Column
    c2 = rng(1).Column + rng.Columns.Count - 1
    Set idRng = Range(Cells(r1 + 1, c1), Cells(r2, c1))
   
    Do While cht.SeriesCollection.Count > 0
        cht.SeriesCollection(1).Delete
    Loop
   
    cht.ChartType = xlColumnClustered
    cht.ApplyCustomType ChartType:=xlBuiltIn, TypeName:="Kurve - søjle"
    For serie = 1 To s
        cht.SeriesCollection.NewSeries
        cht.SeriesCollection(serie).Name = Cells(1, serie + 2).Value
        cht.SeriesCollection(serie).XValues = idRng
        cht.SeriesCollection(serie).Values = Range(Cells(r1 + 1, serie + 2), Cells(r2, serie + 2))
    Next serie
   
    cht.ApplyCustomType ChartType:=xlBuiltIn, TypeName:="Kurve - søjle"
    cht.SeriesCollection(2).Smooth = True
    For serie = 1 To s
        For Each c In Range(Cells(r1 + 1, serie + 2), Cells(r2, serie + 2))
            punkt = c.Row - r1
            If serie = 2 Then
                If Trim(UCase(Cells(c.Row, c1 + 1).Value)) = "KAM" Then
                    cht.SeriesCollection(serie).Points(punkt).MarkerForegroundColorIndex = 3
                    cht.SeriesCollection(serie).Points(punkt).MarkerBackgroundColorIndex = 3
                Else
                    cht.SeriesCollection(serie).Points(punkt).MarkerForegroundColorIndex = 41
                    cht.SeriesCollection(serie).Points(punkt).MarkerBackgroundColorIndex = 41
                End If
            End If
            If serie = 1 Then
             
                If Trim(UCase(Cells(c.Row, c1 + 1).Value)) = "KAM" Then
                    cht.SeriesCollection(serie).Points(punkt).Interior.ColorIndex = 3
                Else
                    cht.SeriesCollection(serie).Points(punkt).Interior.ColorIndex = 41
                End If
            End If
           
        Next
   
    Next serie
   
   
End Sub

Jeg kigger lige på det. Foreløbig tak :-)