lagkager automatisk ændring af størrelse

Var det en idé i stedet at vise det som et stablet søjlediagram (stacked column)? Som jo netop viser de 2 ting i forhold til hinanden.

Det har jeg faktisk allerede lavet, men jeg ville bare gerne vide om det andet overhovedet kan lade sig gøre.

lidt inspiration

http://pmexcelent.dk/GrafScale.xls

Jeg har prøvet at sætte koden ind i et ark. Og den ser ud som følger


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B7", "D2:D7")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([b2:b7])
y1 = Application.WorksheetFunction.Sum([d2:d7])
s = y1 / x1 * 100

x = ActiveSheet.Shapes("Diagram 1").Width / 100 * s
y = ActiveSheet.Shapes("Diagram 1").Height / 100 * s
ActiveSheet.Shapes("Diagram 2").Width = x
ActiveSheet.Shapes("Diagram 2").Height = y

End Sub


Men når jeg ændrer på en værdi, så kommer den op med meddelelsen:

Run-time error '-2147024809 (80070057)':
Emnet med det angivne navn blev ikke fundet.

Hvis man prøver at debugge er følgende linie markeret:

x = ActiveSheet.Shapes("Diagram 1").Width / 100 * s

indsæt følgende i et alm. modul
Aktiver ark med dine grafer
kør og noter grafnavne
hvis de ikke svarer til navne i ovenstående kode skal de rettes til

Sub TestNavn()
For t = 1 To ActiveSheet.ChartObjects.Count
MsgBox ("") & ActiveSheet.ChartObjects(t).Name
Next
End Sub

Jeg har lige prøvet at lave makroen og graferne i et helt ny excel-fil, og så virker det fint, men når jeg sætter det ind i den fil jeg arbejder på kommer den op med fejlmeddelelsen. Der er godt nok også en masse andre makroer i denne fil, men det har vel ikke noget at sige. Der er godt i ikke nogen makro i det ark, hvor jeg arbejder. Kan du gennemskue hvorfor det ikke virker?

der må kun være 1 af følgende evntskode i hvert ark

Private Sub Worksheet_Change(ByVal Target As Range)

og kan ikke udelukke at andre evntskoder kan forstyrre afvikling

ellers er du velkommen til at sende dit ark

I This wordbook har jeg indsat nedstående, jeg ved ikke om det kan
forstyrre.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = "Existing" Then
        Range("H2").Select
    Else
        Range("E15").Select
    End If
End Sub
Sub sletUdvalgte()
Const ark1c = "C14:C22,C26,C28,C30,C35,E15,F14:F22,F26,F28,F30,F35,H15"
Const ark1r = "C13,F13"
Const ark1b = "H2:H7"
Const ark2c = "C23,C24,C33,C34,C35,C40,E15,F23,F24,F33,F34,F35,F40,H15"
Const ark2r = "C21,F21,C25,F25"
Const ark2b = "C20"
Const ark2a = "F20"
Const ark2d = "E15"
Const ark2e = "H15"
Const ark3c = "C20,C22,C26,C29,C30,C31,C36,E15,F20,F22,F26,F29,F30,F31,F36,H15"
Const ark3r = "C21,F21,C23,F23"
Const ark3b = "C20"
Const ark3a = "F20"

    nulstil 1, ark1c, 0
    nulstil 1, ark1r, "-"
    nulstil 1, ark1b, " "      'eller "" henholds blank= " " tom = ""
    nulstil 2, ark2c, 0
    nulstil 2, ark2r, "-"
    nulstil 2, ark2b, "=Existing!C18"
    nulstil 2, ark2a, "=Existing!F18"
    nulstil 2, ark2d, "=Existing!E15"
    nulstil 2, ark2e, "=Existing!H15"
    nulstil 3, ark3c, 0
    nulstil 3, ark3r, "-"
    nulstil 3, ark3b, "=Existing!C18"
    nulstil 3, ark3a, "=Existing!F18"


    Worksheets("Existing").Activate        '<<<<<<<<<<<<<
End Sub

Private Sub nulstil(ArkNr, område, tegn)
    Worksheets(ArkNr).Activate
    ActiveSheet.Unprotect
        Range(område).Select
        Selection.Value = tegn
    ActiveSheet.Protect
End Sub

du kan evt. prøve at fjerne koden og se om det hjælper
(kopier koden, indsæt den i en wordpad-fil, så er den nem at hente tilbage igen)

kan se du har beskyttesle på
gælder det også område hvor kildedata er ?

Jeg tror det virker nu, jeg fjernede bare koden, lavede lagkagerne og satte koden ind igen og så fungerer det fint. Nu er der bare det problem at jeg gerne vil bygge cirklerne op på henvisninger til et andet ark, men når jeg gør det skifter cirkel nummer 2 ikke størrelse.

hvad hedder dine ark ?
i hvilket er grafer
og i hvilket er kildedata

Ja, der er beskyttelse, der hvor der er kildedata, det kan være der skal tages højde for det i koden.

jeg har flyttes koden til det ark hvor kildedata er
derefter har jeg ændret koden så den henviser til arket med graf

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B5", "D2:D5")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([b2:b5])
y1 = Application.WorksheetFunction.Sum([d2:d5])
s = y1 / x1 * 100

x = Sheets("Graf").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Graf").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y

End Sub

skal nok rettes lidt til hos dig

Kildedataene kommer fra to forskellige ark, hvad gør jeg så?

så kan du indsætte kode i begge ark
så skal denne linie rettes så den dækker indtastningsområde

If Intersect(Target, Range("B2:B5", "D2:D5")) Is Nothing Then Exit Sub

man kunne også få opdateret graferne når grafarket aktiveres

er tilbage om et par timer

Ved ikke lige helt hvad jeg skal slette. Jeg har et ark, som hedder existing, hvor der skal henvises til cellerne C25-c30, og et ark som hedder ProposalCash, hvor der skal henvises til cellerne c29-c35.

Det skulle gerne være sådan at grafarket opdateres, så snart man ændrer tallene.

denne i existing :(ret Graf til dit graf-arknavn

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C25:C30")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([b2:b5])
y1 = Application.WorksheetFunction.Sum([d2:d5])
s = y1 / x1 * 100

x = Sheets("Graf").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Graf").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y
End Sub

og denne i ProposalCash:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C29:C35")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([b2:b5])
y1 = Application.WorksheetFunction.Sum([d2:d5])
s = y1 / x1 * 100

x = Sheets("Graf").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Graf").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y

End Sub

Jeg har sat koderne ind i de to ark. I Existing ser det sådan ud.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C25:C30")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([b2:b7])
y1 = Application.WorksheetFunction.Sum([d2:d8])
s = y1 / x1 * 100

x = Sheets("Lagkage-prøve").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Lagkage-prøve").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y
End Sub

og i ProposalCash ser det sådan ud:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C29:C35")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([b2:b7])
y1 = Application.WorksheetFunction.Sum([d2:d8])
s = y1 / x1 * 100

x = Sheets("Lagkage-prøve").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Lagkage-prøve").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y

Men når jeg taster en værdi ind i felt i Existing siger den - Runtime error6 Overflow

Og når jeg taster noget ind i ProposalCash siger den Compile error expected end sub

og linien Private Sub Worksheet_Change(ByVal Target As Range) bliver markeret.

Existing:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("c25:c30")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([c25:c30])
y1 = Application.WorksheetFunction.Sum([ark2!c29:c35])
s = y1 / x1 * 100
x = Sheets("Graf").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Graf").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y
End Sub

ProposalCash:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("c29:c35")) Is Nothing Then Exit Sub
x1 = Application.WorksheetFunction.Sum([ark1!c25:c30])
y1 = Application.WorksheetFunction.Sum([c29:c35])
s = y1 / x1 * 100
x = Sheets("Graf").Shapes("Diagram 1").Width / 100 * s
y = Sheets("Graf").Shapes("Diagram 1").Height / 100 * s
Sheets("Graf").Shapes("Diagram 2").Width = x
Sheets("Graf").Shapes("Diagram 2").Height = y
End Sub

håber jeg har husket det hele

det havde jeg så ikke kan jeg se

slet ark2 i Existing denne til:
y1 = Application.WorksheetFunction.Sum([ProposalCash!c29:c35])

og ark1 i ProposalCash til:
x1 = Application.WorksheetFunction.Sum([Existing!c25:c30])

Så var der langt om længe gevinst. Tusind tak fordi du gad bruge så meget tid på det.

Smid et svar!

Jeg kan lige se at der har sneget sig en lille bug ind, Jeg har i This wordbook lavet en makro der kun nulstille data i nogle af arkene i min fil.

Den ser ud som følger:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = "Existing" Then
        Range("H2").Select
    Else
        Range("E15").Select
    End If
End Sub
Sub sletUdvalgte()
Const ark1c = "C14:C22,C26,C28,C30,C35,E15,F14:F22,F26,F28,F30,F35,H15"
Const ark1r = "C13,F13"
Const ark1b = "H2:H7"
Const ark2c = "C23,C24,C33,C34,C35,C40,E15,F23,F24,F33,F34,F35,F40,H15"
Const ark2r = "C21,F21,C25,F25"
Const ark2b = "C20"
Const ark2a = "F20"
Const ark2d = "E15"
Const ark2e = "H15"
Const ark3c = "C20,C22,C26,C29,C30,C31,C36,E15,F20,F22,F26,F29,F30,F31,F36,H15"
Const ark3r = "C21,F21,C23,F23"
Const ark3b = "C20"
Const ark3a = "F20"

    nulstil 1, ark1c, 0
    nulstil 1, ark1r, "-"
    nulstil 1, ark1b, " "      'eller "" henholds blank= " " tom = ""
    nulstil 2, ark2c, 0
    nulstil 2, ark2r, "-"
    nulstil 2, ark2b, "=Existing!C18"
    nulstil 2, ark2a, "=Existing!F18"
    nulstil 2, ark2d, "=Existing!E15"
    nulstil 2, ark2e, "=Existing!H15"
    nulstil 3, ark3c, 0
    nulstil 3, ark3r, "-"
    nulstil 3, ark3b, "=Existing!C18"
    nulstil 3, ark3a, "=Existing!F18"


    Worksheets("Existing").Activate        '<<<<<<<<<<<<<
End Sub

Private Sub nulstil(ArkNr, område, tegn)
    Worksheets(ArkNr).Activate
    ActiveSheet.Unprotect
        Range(område).Select
        Selection.Value = tegn
    ActiveSheet.Protect
End Sub


Jeg tror den kommer i kambolage med den nye makro. Når jeg trykker på den knap jeg har lavet til at nustille siger der, runtime error '11' Division by zero

kunne evt. løses med :

If y1 = 0 Or x1 = 0 Then Exit Sub

indsæt lige før denne: (i begge koder)

s = y1 / x1 * 100

Nu virker det helt perfekt, smid et svar.

kommer her