grafieken kopieren naar andere tabbladen zonder verwijzingen

[ekeiram]

hallo,

Onderstaand een uitdaging die ik niet voor elkaar krijg en ik hoop dat jullie me er mee kunnen helpen. Van de week geweldig geholpen met de add in Excel-explosion, ben er nog steeds heel gelukkig mee .

Zie ook de bijlage waarin ik heb geprobeerd het te verduidelijken. Bedoeling is dat boven de gegevens die in de sheet staan (verkregen uit Explosion) een soort van dashboard komt te staan (voor het totale beeld zie sheet 2, waarbij zwart de waarden zijn die worden ingevuld en grijs de waarden die er standaard al staan).

Dit dashboard wordt opgebouwd met de gegevens die in sheet 1 bovenaan staan. De gegevens en de grafieken komen dus over elkaar heen de staan (zie sheet 2 voor het totale plaatje). Nu heb ik ongeveer 100 tabbladen met verschillende namen waar dit boven moet komen te staan. Hier heb ik geprobeerd een macro voor te maken (staat in de bijlage), echter het gaat mis bij de namen en bij de verwijzingen in de grafieken.

In 'mijn' macro wordt namelijk alles steeds verwezen naar de sheet waar ik het de eerste keer heen heb gekopieerd in plaats van alle sheets in die workmap. Tevens verwijzen de grafieken steeds naar het bronbestand en dus niet naar de betreffende tab waar hij op dat moment staat (zie sheet 3)

Er moet toch een mogelijkheid zijn om de grafieken niet te laten verwijzen naar het bronbestand, maar naar de gegevens van die tab en dat dan op elk tabblad te doen?

Hoop dat het een beetje duidelijk is,

alvast bedankt voor de hulp.

Marieke

 

[ekeiram]

Niemand?

 

[cow18]

Sub HernoemenReeks1()
  Dim sh As Worksheet, ch As Object, sSerie As String, sVorig As String, sNieuw As String

  For Each sh In Worksheets                                'loop alle werkbladen af
    For Each ch In sh.ChartObjects                         'loop elke grafiek af
      sSerie = ch.Chart.SeriesCollection(1).Formula        'formules voor de 1e reeks
      sVorig = Mid(Left(sSerie, InStr(1, sSerie, "!") - 1), InStr(sSerie, ",") + 1, 255)  'naam van het vorige tabblad
      sNieuw = Replace(sSerie, sVorig, ActiveSheet.Name, 1)  'vervang naam vorig tabblad door huidig tabblad
      ch.Chart.SeriesCollection(1).Formula = sNieuw        'stop dat terug in reeks1
    Next
  Next
End Sub

 

[ekeiram]

dank je wel!

Begrijp het alleen niet helemaal hoe ik dit het beste werkende kan krijgen. Door jouw macro te laten draaien worden inderdaad de grafieken bijgewerkt in de voorbeeldsheet, top, dank!

Helaas als ik dan de macro wil laten draaien in het uiteindelijke bestand (met de 100 tabs) dan krijg ik een error (ik heb sheet 1 en 2 uit de voorbeeldsheet verplaatst naar het uiteindelijke bestand zodat de gegevens daar uit gehaald kunnen worden). De error zegt:

runtime error 1004

application-defined or object-defined error

en een gele balk in de code bij

 ch.Chart.SeriesCollection(1).Formula = sNieuw        'stop dat terug in reeks1

Het kopieren lukt niet automatisch naar alle sheets (mijn macro blijft alles kopieren naar sheet 3) dus dit had ik handmatig gedaan zodat de koppelingen daarna met jouw macro zouden gaan werken alleen daarna kwam de error.

Wanneer ik niet sheet1 en sheet2 vanuit het voorbeeldbestand meeneem en de eerste grafiek kloppend maak en daarna (ook weer handmatig) de macro probeer te laten draaien werkt hij helemaal niet.

Het is een verwijzing ergens heen waarschijnlijk, maar ik kan nergens achterhalen waarheen zodat ik die mee kan nemen of ergens kan aanpassen

Hoop dat je me hier weer mee zou willen helpen.

Dank alvast!

Marieke

 

[cow18]

moeilijke gok, vermoedelijk is er ook ergens een grafiek waar er geen 1e reeks aanwezig is ???
dus nu een extra loopje voor die reeksen en een "on error ..."

Sub HernoemenReeks1()
  Dim sh As Worksheet, ch As Object, Reeks As Variant, sSerie As String, sVorig As String, sNieuw As String
  On Error Resume Next
  For Each sh In Worksheets                                'loop alle werkbladen af
    For Each ch In sh.ChartObjects                         'loop elke grafiek af
      For Each Reeks In ch.Chart.SeriesCollection          'loop iedere reeks af
        Err.Clear                                          'eventueel vroeger foutnummer wissen
        sSerie = Reeks.Formula                             'formules voor de 1e reeks
        sVorig = Mid(Left(sSerie, InStr(1, sSerie, "!") - 1), InStr(sSerie, ",") + 1, 255)  'naam van het vorige tabblad
        sNieuw = Replace(sSerie, sVorig, ActiveSheet.Name, 1)  'vervang naam vorig tabblad door huidig tabblad
        ch.Chart.SeriesCollection(1).Formula = sNieuw      'stop dat terug in reeks1
        If Err.Number <> 0 Then                            'fout opgetreden in die paar regels, dan foutboodschap
          MsgBox "FOUT in " & vbLf & "tabblad " & sh.Name & vbLf & "grafiek " & ch.Name & vbLf & "serie " & Reeks.Name & vbLf & "de formule werd " & vbTab & sNieuw
        End If
      Next
    Next
  Next
End Sub

 

[ekeiram]

met dank aan deze geeft hij perfect aan waar de fout zit, alleen hoe het op te lossen?
-zie bijlage-

waarbij A28HE- de naam van de sheet is. Bij andere sheets geeft hij dezelfde melding met de naam van die sheet erin

nogmaals dank alvast

 

[cow18]

het heeft me toch eventjes wat hoofdbrekens gekost, maar achteraf ziet het er toch simpel uit.
Vooral de naam van de reeks in een kolomgrafiek leverde het probleem, dus tijdelijk er een xy van maken, en dan terugzetten

ik kan blijkbaar die file hier niet zetten, dus weer de code

Option Explicit

Sub HernoemenReeks1()
  Dim sh As Worksheet, ch As Object, Reeks As Variant, sNieuw As String, bKOL As Boolean
  On Error Resume Next
  For Each sh In Worksheets                                'loop alle werkbladen af
    For Each ch In sh.ChartObjects                         'loop elke grafiek af
      bKOL = (ch.Chart.ChartType = xl3DColumnClustered)    'is grafiektype = 3D kolommen ??
      If bKOL Then ch.Chart.ChartType = xlLineMarkers      'tijdelijk omzetten naar linemarkers
      For Each Reeks In ch.Chart.SeriesCollection          'loop iedere reeks af
        sNieuw = NewSerie(Reeks.Formula, sh.Name)          'vervang naam vorig tabblad door huidig tabblad
        Err.Clear                                          'eventueel vroeger foutnummer wissen
        Reeks.Formula = sNieuw                             'stop dat terug in reeks1
        If Err.Number <> 0 Then                            'fout opgetreden in die paar regels, dan foutboodschap
          MsgBox "FOUT in " & vbLf & "tabblad " & sh.Name & vbLf & "grafiek " & ch.Name & vbLf & "serie " & Reeks.Name & vbLf & "de formule werd " & vbTab & sNieuw
        End If
      Next
      If bKOL Then ch.Chart.ChartType = xl3DColumnClustered  'terugzetten naar kolom indien het een kolom wzs
    Next
  Next
End Sub

Function NewSerie(OldSerie As String, HuidigWerkblad As String) As String
  Dim sVorig   As String
  On Error Resume Next
  sVorig = Left(OldSerie, InStrRev(OldSerie, "!") - 1)
  sVorig = Mid(Left(sVorig, InStrRev(OldSerie, "!") - 1), InStrRev(sVorig, ",") + 1, 255)
  sVorig = Mid(Left(OldSerie, InStrRev(1, OldSerie, "!") - 1), InStrRev(OldSerie, ",") + 1, 255)  'naam van het vorige tabblad
  NewSerie = Replace(OldSerie, sVorig, HuidigWerkblad, 1)  'vervang naam vorig tabblad door huidig tabblad
End Function

 

[ekeiram]

vind het echt super lief dat je blijft helpen, dank je wel!

Van welke reeks moet ik XY maken? Begrijp het niet helemaal en dat verklaard waarschijnlijk waarom het niet werkt

 

[cow18]

in jouw voorbeeldje werkt het wel, ik heb in sheet1 wat labels een andere naam gegeven en daar enkele formules vervangen door een getal om zo tot een grafiek te komen, hij verwijst dus netjes naar dat tabblad.
Als het in jouw voorbeeld niet gaat, dan zou ik moeten weten op welke grafiek hij plat gaat, ik weet niet of je nog andere types in gebruik hebt dan de 2 die in je bijlage zaten ?

 

[ekeiram]

super dat je weer reageert!

In de bijlages het bestand (verkleind) waar ik het in probeer te krijgen met de error. Ik hoop dat dit het iets meer uitlegd

 

[cow18]

het grappige is dat het bereik wel netjes werd aangepast, maar dat hij toch met een foutboodschap voor de dag kwam, die stond dus iets te gevoelig, nu wordt dat afgevangen door nadat je het bereik aangepast hebt, dat opnieuw op te vragen en te kijken of het het gewenste is (stukje in het rood).
Dus in principe werkte de vorige versie goed, maar gaft teveel foutboodschappen en dat zou bij deze moeten opgelost zijn

Option Explicit

Sub HernoemenReeks1()
  Dim sh As Worksheet, ch As Object, Reeks As Variant, sNieuw As String, bKOL As Boolean
  On Error Resume Next
  For Each sh In Worksheets                                'loop alle werkbladen af
    For Each ch In sh.ChartObjects                         'loop elke grafiek af
      bKOL = (ch.Chart.ChartType = xl3DColumnClustered)    'is grafiektype = 3D kolommen ??
      If bKOL Then ch.Chart.ChartType = xlLineMarkers      'tijdelijk omzetten naar linemarkers
      For Each Reeks In ch.Chart.SeriesCollection          'loop iedere reeks af
        sNieuw = NewSerie(Reeks.Formula, sh.Name)          'vervang naam vorig tabblad door huidig tabblad
        Reeks.Formula = sNieuw                             'stop dat terug in reeks1
       [COLOR="red"] If Reeks.Formula <> sNieuw Then                    [/COLOR]'kijk of het er goed in staat, anders foutboodschap
          MsgBox Err.Number & " FOUT in " & vbLf & "tabblad " & sh.Name & vbLf & "grafiek " & ch.Name & vbLf & "serie " & Reeks.Name & vbLf & "de formule werd " & vbLf & sNieuw & vbLf & Reeks.naam
        End If
      Next
      If bKOL Then ch.Chart.ChartType = xl3DColumnClustered  'terugzetten naar kolom indien het een kolom wzs
    Next
  Next
End Sub

Function NewSerie(OldSerie As String, HuidigWerkblad As String) As String
  Dim sVorig   As String
  On Error Resume Next
  sVorig = Left(OldSerie, InStrRev(OldSerie, "!") - 1)
  sVorig = Mid(Left(sVorig, InStrRev(OldSerie, "!") - 1), InStrRev(sVorig, ",") + 1, 255)
  sVorig = Mid(Left(OldSerie, InStrRev(1, OldSerie, "!") - 1), InStrRev(OldSerie, ",") + 1, 255)  'naam van het vorige tabblad
  NewSerie = Replace(OldSerie, sVorig, HuidigWerkblad, 1)  'vervang naam vorig tabblad door huidig tabblad
End Function

 

[ekeiram]

geen errors meer, maar de grafiek verwijzingen worden helaas nu ook niet aangepast

Ik denk dat ik weet hoe het komt, via onderstaande code wordt namelijk naar de vorige sheet verwezen.

sNieuw = NewSerie(Reeks.Formula, sh.Name)          'vervang naam vorig tabblad door huidig tabblad

Dit zou inderdaad werken op het moment dat de grafieken in elke sheet automatisch worden gekopieerd. Helaas doe ik dit nu handmatig (krijg het automatisch niet voor elkaar), waardoor dus alles wordt gekopieerd vanuit Sheet1 en de verwijzing niet de vorige sheet, maar Sheet1 betreft.

Ik weet alleen niet hoe dit aan te passen, als je me daar ook nog mee wilt helpen ben ik je echt heel dankbaar

groetjes, Marieke

 

[cow18]

op hoop van zege, het zit hem vermoedelijk in die enkele aanhalingstekens in de voorlaatste regel van die function

Sub HernoemenReeks1()
  Dim sh As Worksheet, ch As Object, Reeks As Variant, sNieuw As String, bKOL As Boolean, old As String
  'On Error Resume Next
  For Each sh In Worksheets                                'loop alle werkbladen af
    For Each ch In sh.ChartObjects                         'loop elke grafiek af
      bKOL = (ch.Chart.ChartType = xl3DColumnClustered)    'is grafiektype = 3D kolommen ??
      If bKOL Then ch.Chart.ChartType = xlLineMarkers      'tijdelijk omzetten naar linemarkers
      For Each Reeks In ch.Chart.SeriesCollection          'loop iedere reeks af
        sNieuw = NewSerie(Reeks.Formula, sh.Name)          'vervang naam vorig tabblad door huidig tabblad
        Reeks.Formula = sNieuw                             'stop dat terug in reeks1
        If Reeks.Formula <> sNieuw And Reeks.Formula <> Replace(sNieuw, "'", "") Then  'kijk of het er goed in staat, anders foutboodschap
          MsgBox Err.Number & " FOUT in " & vbLf & "tabblad " & sh.Name & vbLf & "grafiek " & ch.Name & vbLf & "serie " & Reeks.Name & vbLf & "de formule werd " & vbLf & sNieuw & vbLf & Reeks.naam
        End If
      Next
      If bKOL Then ch.Chart.ChartType = xl3DColumnClustered  'terugzetten naar kolom indien het een kolom wzs
    Next
  Next
End Sub

Function NewSerie(OldSerie As String, HuidigWerkblad As String) As String
  Dim sVorig   As String
  On Error Resume Next
  sVorig = Left(OldSerie, InStrRev(OldSerie, "!") - 1)
  sVorig = Mid(Left(sVorig, InStrRev(OldSerie, "!") - 1), InStrRev(sVorig, ",") + 1, 255)
  sVorig = Mid(Left(OldSerie, InStrRev(1, OldSerie, "!") - 1), InStrRev(OldSerie, ",") + 1, 255)  'naam van het vorige tabblad
  HuidigWerkblad = IIf(Left(HuidigWerkblad, 1) <> "'", "'", "") & HuidigWerkblad & IIf(Right(HuidigWerkblad, 1) <> "'", "'", "")
  NewSerie = Replace(OldSerie, sVorig, HuidigWerkblad, 1)  'vervang naam vorig tabblad door huidig tabblad
End Function

 

[ekeiram]

Sorry voor de late reactie, was er even tussen uit

HIJ WERKT!!!

Dank je wel!!Echt heeeeeel blij mee, dank dank dank! Super!:thumb::thumb: