XL 2016 Mise à jour tableau croisé depuis la feuille de calcul

STephane · 22 Janvier 2020

Bonjour

Suite à destruction de mon fichier de macros personnelles et de mes backup après mise à jour antivirus sur le réseau d'entreprise, j'ai perdu 8 mois de macros et une particulière, récemment concoctée pour mettre à jour les données sources d'un tableau croisé dynamique (via gestion évènementielle).

Pour réussir, je détectais la cellule double-cliquée et recherchait l'enregistrement concerné dans la base source en récupérant la clé principale (soit première zone du TCD, soit avec son nom) de l'enregistrement cliqué.

Quelqu'un aurait cela dans son escarcelle, avant de me replonger et tout recoder ?

Merci
STéphane

L'idée était de servir d'un TCD pour suivre au jour le jour une activité (enfin c'est très rudimentaire, je n'ai pas reprocédé à l'import automatique des données, sachant qu'en plus le fichier source n'a pas forcément le même nombre de colonnes.

sylvanu · 27 Janvier 2020

Bonjour Stéphane,
Bad news.
Mais normalement sur un réseau d'entreprise le service informatique procède à des sauvegardes périodiques. C'est leur job de maintenir la pérennité des données.
Avez vous fouillé dans ces archives pour peut être y trouver un ancien fichier même si ce n'est pas le dernier ?

STephane · 27 Janvier 2020

Sylvanu,

Merci pour ton retour. Je vais vérifier mais je ne pense pas que ce soit le cas. Etant un fichier de "macros personnelles", je ne le mettrais pas sur un OneDrive (ou autre) d'entreprise. ;-)

Qui plus est à chaque fois que je télécharge une vieille version, elle est aussi scratchée par l'antivirus.

Je suis parti pour la recréer mais je coinçe sur la gestion de la SourceData (le convertformula ne veut pas marcher).

STephane · 27 Janvier 2020

Voilà, j'ai réécrit un truc, à tester et retester (notamment si le tableau source ne démarre pas en A1, mais en B2 par exemple, et s'il contient plusieurs sources !). Code à insérer dans la feuille de code du classeur ThisWorkbook).

Pour tester, relancer la procédure workbook_open (à chaque fois que vous arrêtez l'exécution du code).

VB:

Private Sub Workbook_Open()
Set App = Application
'Application.ReferenceStyle = xlA1
End Sub
Private Sub App_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim sClickedFieldName As String
Dim sPivotUniqueKey As String
Dim PT As Excel.PivotTable
Dim SourceDataSheet As String
Dim sSheetTrim As String
Dim sRangeTrim As String
Dim dataArea As Range

On Error Resume Next

'# Name of the pivot table major key
sPivotUniqueKey = "Request item"


Set PT = Target.Item(1).PivotTable
If Err.Number <> 0 Then GoTo Jump_01

'# Get clicked field name
sClickedFieldName = Sh.Cells(PT.TableRange1.Rows(1).Row, Target.Column)
Debug.Print sClickedFieldName

'# Get cliked record unique key
sClickedRecordKey = Sh.Cells(Target.Row, PT.TableRange1.Rows(1).Find(sPivotUniqueKey).Column)
 Debug.Print sClickedRecordKey
'# It could be managed alternatively considering first field of pivot table if it's always the unique key


'# Get pivot range in variable dataArea
rgDataSource = Replace(PT.SourceData, "L", "R")
rgDataSource = Replace(Application.ConvertFormula( _
            Formula:=rgDataSource, _
            fromReferenceStyle:=xlR1C1, _
            toReferenceStyle:=xlA1, _
            toAbsolute:=xlAbsolute), _
            "[" & ThisWorkbook.Name & "]", "")
Set dataArea = Range(rgDataSource)

'# Get pivot worksheet
Set shDataSource = dataArea.Parent

''    sSheetTrim = Split(SourceDataSheet, "!")(0)
''    sSheetTrim = Split(SourceDataSheet, "'")(1)
''    sSheetTrim = Split(sSheetTrim, "]")(1)

    'some trimming to get desired references for lastRow (sheet in which the SourceData are located) and dataArea (starting cell and last column of SourceData)
'' sRangeTrim = Left(dataArea.Address, 8)


'# Determine the cell to be updated in the data source
lDataSourceKeyColumn = shDataSource.Rows(1).Find(sPivotUniqueKey).Column
lDataTargetColumn = shDataSource.Rows(1).Find(sClickedFieldName).Column
lDataSourceRecordRow = shDataSource.Cells(1, lDataSourceKeyColumn).EntireColumn.Find(sClickedRecordKey).Row
Set rgDataSourceTargetField = dataArea.Cells(lDataSourceRecordRow, lDataTargetColumn)


'# Update data source (if it's not a field with formula)
If shDataSource.Range(rgDataSourceTargetField.Address).HasFormula = False Then
    shDataSource.Range(rgDataSourceTargetField.Address).Value = Target.Item(1).Value
End If
Jump_01:

End Sub

XL 2016 Mise à jour tableau croisé depuis la feuille de calcul

STephane

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

STephane

XLDnaute Occasionnel

STephane

XLDnaute Occasionnel

Discussions similaires