Actualisation de formule

[boniteprobtp]

Lors d'une copie d'une feuille contenant des graphes entre deux fichiers excel, les graphes conservent le lien vers le fichier source. J'ai bien fait en sorte que toutes les feuilles utiles aux graphes soient au préalable recopiées dans le nouveau fichier. Comment peut-on casser les liens pour que les graphes pointent sur les feuilles internes au nouveau fichier ? Le tout est fait en VBA donc cette actualaisation doit être faite également en VBA.

Merci pour votre aide

 

[James007]

Re : Actualisation de formule

Bonjour,

Pour une réponse adaptée à ta situation particulière, n'hésites pas à partager ton classeur et ton code VBA ... car il existe plusieurs façons de copier des graphes ...

A +

 

[boniteprobtp]

Re : Actualisation de formule

Aucun problème pour partager mon code VBA, la recopie entre deux classeurs se fait justement via ce code que voici.

Sub chargerDonnees()


On Error GoTo errChargerDonnees
Dim nb As Integer, nbFeuille As Integer
Dim Feuille As String, newFeuille As String
Dim repertoire As String
Sheets("Accueil").Activate
serveur = "c:\Dossiers\Communs"
serveur = InputBox("A quel serveur souhaitez-vous accéder ?", "Nom serveur", serveur)
repertoire = serveur + "\EvolutionExcel"
repertoire = InputBox("A quel répertoire souhaitez-vous accéder ?", "Nom répertoire", repertoire)
Dim fichier As String
fichier = "Resultat Palmares ETAB Obj.xlsm"
Dim newFichier As String
newFichier = "Resultat Palmares.xlsm"
fichier = InputBox("Quel fichier souhaitez-vous traiter ?", "Nom fichier", fichier)
Workbooks.Open Filename:=repertoire + "/" + fichier
Dim i As Integer, j As Integer, k As Integer
Dim tableauFeuille(1 To 20) As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'
' ==========> recherche des feuilles à charger
'
For i = 1 To Sheets.Count
If Not Left(Sheets.Item(i).Name, 5) = "Feuil" Then
tableauFeuille(i) = Sheets.Item(i).Name
MsgBox "feuille à charger : " + Sheets.Item(i).Name, 0, "Chargement"
End If
Next i
'
' ==========> chargement des intitulés des nouvelles feuilles
'
Dim maFeuille As String
Dim saFeuille As String
Windows(newFichier).Activate
For j = 1 To i
saFeuille = tableauFeuille(j)
For k = 2 To 20
maFeuille = Sheets("ParamExecution").Cells(k, 1)
If maFeuille = saFeuille Then
Exit For
Else
If Sheets("ParamExecution").Cells(k, 1).Text = "" Then
Sheets("ParamExecution").Cells(k, 1).Value = tableauFeuille(j)
Sheets("ParamExecution").Cells(k, 3).Value = "Oui"
MsgBox "feuille ajoutée : " + tableauFeuille(j), 0, "Chargement"
Exit For
End If
End If
Next k
Next j
'
' ==========> chargement des feuilles
'
For i = 2 To 20
Feuille = Sheets("ParamExecution").Cells(i, 1).Text
MsgBox "feuille : " + Feuille, 0, "Chargement"
If Not Feuille = "" Then
nbFeuille = Sheets.Count
Sheets.Add After:=Sheets(Sheets.Count)
nb = Sheets.Count
newFeuille = Sheets.Item(nb).Name
Windows(fichier).Activate
Sheets(Feuille).Activate
Application.Cells.Select
Selection.Copy
Windows(newFichier).Activate
Sheets(newFeuille).Select
Application.Cells.Select
ActiveSheet.Paste
Sheets(newFeuille).Select
Sheets(newFeuille).Name = Feuille
Else
Exit For
End If
Next i
'
' ==========> réinitialiser les liens sur le nouveau classeur Excel
'
Cells.Replace What:=repertoire + "/" + fichier, _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:= _
False, _
ReplaceFormat:=False
Cells.Replace What:="'[Resultat Palmares ETAB Obj.xlsx]Fabriq'", _
Replacement:="Fabriq", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:= _
False, _
ReplaceFormat:=False
Cells.Replace What:="'[Resultat Palmares ETAB Obj.xlsx]Resultat'", _
Replacement:="Resultat", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:= _
False, _
ReplaceFormat:=False
Cells.Replace What:="'[Resultat Palmares ETAB Obj.xlsx]Evol'", _
Replacement:="Evol", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:= _
False, _
ReplaceFormat:=False
'
' ==========> Fermeture du fichier des données
'
Windows(fichier).Activate
ActiveWindow.Close
GoTo exitChargerDonnees
'
' ==========> sauvegarde du fichier de données en fichier avec macro
'
'ActiveWorkbook.SaveAs Filename:= _
' repertoire + "\" + Mid(fichier, 1, Len(fichier) - 5) + ".xlsm", FileFormat:= _
' xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
errChargerDonnees:
MsgBox "Code erreur : " + Err + " en " + Erl + " - " + Error, 0, "Erreur"
exitChargerDonnees:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

End Sub

Je recherche pour commencer les feuilles à recopier sur mon classeur source puis je les charges dans mon nouveau classeur. Une de ces feuilles est composée de graphe faisant référence à d'autres feuilles qui ont été préalablement recopiées et ce sont ces liens que je voudrais casser car ils se retrouvent avec les coordonnées du classeur source.

Merci pour toute réponse

 

[boniteprobtp]

Re : Actualisation de formule

Mon code a été modifié comme suit, le problème de conservation des référencement reste identique, voici mon nouveau code :

Sub chargerDonnees()

    
    On Error GoTo errChargerDonnees
    Dim nb As Integer, nbFeuille As Integer
    Dim Feuille As String, newFeuille As String
    Dim repertoire As String
    Sheets("Accueil").Activate
    serveur = "g:"
    serveur = InputBox("A quel serveur souhaitez-vous accéder ?", "Nom serveur", serveur)
    repertoire = serveur + "\EvolutionExcel"
    repertoire = InputBox("A quel répertoire souhaitez-vous accéder ?", "Nom répertoire", repertoire)
    Dim fichier As String
    fichier = "Resultat Palmares ETAB Obj.xlsx"
    Dim newFichier As String
    newFichier = "Resultat Palmares.xlsm"
    fichier = InputBox("Quel fichier souhaitez-vous traiter ?", "Nom fichier", fichier)
    Dim wk1 As Workbook
    Dim wk2 As Workbook
    Set wk1 = ActiveWorkbook
    Set wk2 = Workbooks.Open(repertoire + "/" + fichier)
    Dim i As Integer, j As Integer, k As Integer
    Dim tableauFeuille(1 To 20) As String
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    '
    ' ==========> recherche des feuilles à charger
    '
    nbFeuille = 0
    For i = 1 To wk2.Sheets.Count
        If Not Left(wk2.Sheets.Item(i).Name, 5) = "Feuil" Then
            nbFeuille = nbFeuille + 1
            Feuille = wk2.Sheets.Item(i).Name
            Sheets(Feuille).Copy After:=wk1.Sheets(wk1.Sheets.Count)
            wk2.Activate
            tableauFeuille(i) = Feuille
            'MsgBox "feuille à charger : " + Sheets.Item(i).Name, 0, "Chargement"
        End If
    Next i
    wk2.Close False
    '
    ' =====> chargement des feuilles
    '
    For i = 1 To nbFeuille
        Feuille = tableauFeuille(i)
        For j = 2 To 20
            If Sheets("ParamExecution").Cells(j, 1).Value = Feuille Then
                Exit For
            Else
                If Sheets("ParamExecution").Cells(j, 1).Value = "" Then
                    Sheets("ParamExecution").Cells(j, 1).Value = Feuille
                    Sheets("ParamExecution").Cells(j, 3).Value = "Oui"
                    Exit For
                End If
            End If
        Next j
    Next i
    '
    ' ==========> réinitialiser les liens sur le nouveau fichier Excel
    '
    Cells.Replace What:="'" & repertoire & "/[" & fichier & "]Fabriq'", _
        Replacement:="Fabriq", _
        LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        MatchCase:=False, _
        SearchFormat:= _
        False, _
        ReplaceFormat:=False
    '
    ' ==========> Fermeture du fichier des données
    '
    GoTo exitChargerDonnees
    '
    ' ==========> sauvegarde du fichier de données en fichier avec macro
    '
    'ActiveWorkbook.SaveAs Filename:= _
    '    repertoire + "\" + Mid(fichier, 1, Len(fichier) - 5) + ".xlsm", FileFormat:= _
    '    xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
errChargerDonnees:
    MsgBox "Code erreur : " + Err + " en " + Erl + " - " + Error, 0, "Erreur"
exitChargerDonnees:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
     
End Sub

Merci pour ton aide

 

[James007]

Re : Actualisation de formule

Bonjour,

Le code que tu as posté concerne tes fichiers ... et non tes graphiques ...

Si tu veux "détacher" tes graphiques de leurs données source ..., tu peux tester :

Sub DetacherChart()
    Dim mySeries As Series
    Dim sChtName As String

    ' Sélectionner un Graph
    On Error Resume Next
    sChtName = ActiveChart.Name
    If Err.Number <> 0 Then Exit Sub
    If TypeName(Selection) = "ChartObject" Then
        ActiveSheet.ChartObjects(Selection.Name).Activate
    End If
    On Error GoTo 0
    ' Boucle sur les séries du graph
    For Each mySeries In ActiveChart.SeriesCollection
        ' Convertir les valeurs
        mySeries.XValues = mySeries.XValues
        mySeries.Values = mySeries.Values
        mySeries.Name = mySeries.Name
    Next mySeries
End Sub

A +

 

[bonite]

Re : Actualisation de formule

Comment te positionnes tu sur le graphe ? car si je comprends bien ton code agit sur un graphe dans une feuille.

Remersiements et salutations.