Mettre a jour des données sur 2 fichiers

Résolu
vigie5656 Messages postés 9 Statut Membre -  
vigie5656 Messages postés 9 Statut Membre -
Bonjour,
Je ne suis pas un expert loin de là en macro excel, je bute sur un problème sans doute basique.

J'utilise un fichier "Export_eureka" qui consolide les données de plusieurs fichiers, j'ai mis un exemple avec le fichier "EUREKA_Transfo".

Donc les données de "EUREKA_Transfo" sont un sous-ensemble de "Export_eureka".

Cependant, certaines cellules "EUREKA_Transfo" sont modifiées par des utilisateurs, notamment ( les colonnes suivantes S Q P C F Cotation Valid. Bravo), je ne trouve pas la solution pour mettre à jour le fichier consolidé "Export_eureka" à partir d'une macro que je voudrai lancer depuis "EUREKA_Transfo".

Je joins les 2 fichiers, ce sera plus clair. merci de votre aide. Ci-joint la macro que j'ai essayer de bidouiller. 

Sub mise_a_jour_data_transfo()
    Dim Cellule As Range
    Dim data As Workbook
    Dim base As Workbook
    Dim LastLine As Integer
    Dim Tableau1() As Variant
    Dim Tableau2() As Variant
    Dim i As Integer
 
   ' On ouvre le fichier Export_eureka et on lui donne le focus
    Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Consolidation" & "\" & "Export_eureka.xlsm"
    Set data = ActiveWorkbook
    data.Activate
 
    ' On cherche le numéro de la dernière ligne utilisée dans la colonne B
    LastLine = Cells(Rows.Count, "B").End(xlUp).Row
 
    ' On redimensionne les 2 tableaux de façon dynamique
    ReDim Tableau1(LastLine)
    ' On a besoin de stocker les valeurs de 8 colonnes
    ReDim Tableau2(LastLine, 8)
 
    ' On charge le tableau avec les valeurs de la colonne B
    For i = 3 To LastLine
      Tableau1(i) = Range("B" & Trim(Str(i)))
    Next i
 
 
    ' On active le fichier EUREKA_Transfo
        Set base = ActiveWorkbook
        base.Activate
 
 
     ' On scanne la colonne B avec les valeurs contenues dans le tableau
    For i = 3 To LastLine
        Set Cellule = ActiveSheet.Range("Ref").Find(Tableau1(i), lookat:=xlWhole)
        Tableau2(i, 1) = Cellule.Offset(0, 12).Value
        Tableau2(i, 2) = Cellule.Offset(0, 13).Value
        Tableau2(i, 3) = Cellule.Offset(0, 14).Value
        Tableau2(i, 4) = Cellule.Offset(0, 15).Value
        Tableau2(i, 5) = Cellule.Offset(0, 16).Value
        Tableau2(i, 6) = Cellule.Offset(0, 17).Value
        Tableau2(i, 7) = Cellule.Offset(0, 18).Value
        Tableau2(i, 8) = Cellule.Offset(0, 19).Value
    Next i
 
     ' On active le fichier Export_eureka
     Set data = ActiveWorkbook
    data.Activate
 
 
    ' On recopie le contenu du tableau dans les colonnes N à U
    For i = 3 To LastLine
      Range("N" & Trim(Str(i))) = Tableau2(i, 1)
      Range("O" & Trim(Str(i))) = Tableau2(i, 2)
      Range("P" & Trim(Str(i))) = Tableau2(i, 3)
      Range("Q" & Trim(Str(i))) = Tableau2(i, 4)
      Range("R" & Trim(Str(i))) = Tableau2(i, 5)
      Range("S" & Trim(Str(i))) = Tableau2(i, 6)
      Range("T" & Trim(Str(i))) = Tableau2(i, 7)
      Range("U" & Trim(Str(i))) = Tableau2(i, 8)
    Next i
 
'On referme le classeur Export_eureka.xlsm dont on n'a plus besoin
        Set data = ActiveWorkbook
        data.Save
 
 
    ' On active le fichier EUREKA_Transfo
        Set base = ActiveWorkbook
        base.Activate


EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ICI

Merci d'y penser dans tes prochains messages.

6 réponses

  1.
    michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour,

    merci pour les codes mais où sont les classeurs comme tu l'indiques

    Mettre le classeur sans données confidentielles en pièce jointe sur https://www.cjoint.com/
    et coller le raccourci proposé (clic droit) dans le message de réponse

    D'ores et déià, il y a des choses bizzares dans ton code: variables tableaux commencant à 3, des AR apparemment inutiles entre les 2 classeurs, des boucles inutiles aussi...
    mais sans voir les classeurs...

    Dans l'attente
    0
    1. vigie5656
       
      Merci Michel
      Ci-joint le lien : http://www.cjoint.com/c/EIeoBOpfiWK
      Merci
      0
      1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320 > vigie5656
         
        Ok, merci, sois patient !
        je m'occuperai de çà demain ou après-demain !
        0
      2. vigie5656 > michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention  
         
        Merci super, si tu peux demain c'est génial.
        0
  2. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour,

    Gros problème de DDL manquante. pas la 1° fois avec des extractions-cjoint + zip Windows
    bien sûr la macro était terminée et en cours d'essais.... :-(

    envoie moi les 2 classeurs séparement non zippés
    d'avance merci

    edit:
    dans la réalité, combien as tu de lignes dans export ?

    Michel
    0
  3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour

    Décidément !!!

    m^me coup qu'hier. message de Microsoft 

    <?xml version="1.0" encoding="UTF-8" standalone="true"?>
    -<recoveryLog xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">
    <logFileName>error037120_01.xml</logFileName>
    <summary>Des erreurs ont été détectées dans le fichier « D:\docus\EUREKA-Transfo.xlsm »</summary>
    -<removedFeatures summary="Liste des fonctionnalités supprimées ci-dessous :">
    <removedFeature>Fonction supprimée: Objet dans la partie /xl/workbook.xml (Classeur)</removedFeature>
    <removedFeature>Fonction supprimée: OLE Control Extension dans la partie /xl/workbook.xml (Classeur)</removedFeature>
    </removedFeatures>
    </recoveryLog>


    sincèrement désolé :-((
    0
    2. vigie5656 Messages postés 9 Statut Membre
       
      Re bonjour,
      Je viens d'utiliser We transfert, et là ça fonctionne.
      Le lien : http://we.tl/qwUWHgd5Le

      Cdlt
      0
  4. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour,

    Grace à Eriiic, le problème semble résolu!
    cela venait du fait que je n'ai pas Outlook d'installé sur mon coucou

    Donc, je vais essayé de t'envoyer le code ce matin (je ne suis pas là cet après-midi)
    0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    re,
    voilà le code, (ouf !!!) 

    Option Explicit
Option Base 1
'------
Sub ccm_maj()
Dim Derlig As Integer, T_ref, T_maj
Dim Cptr As Integer, Lig As Integer, Col As Byte

    Application.ScreenUpdating = False 'fige l'écran: confort et rapidité
    
    'mémorisation des modifs
    With ThisWorkbook.Sheets("base")
        Derlig = .Columns("B").Find(what:="*", searchdirection:=xlPrevious).Row
        T_ref = Application.Transpose(.Range("B3:B" & Derlig))
        T_maj = .Range("N3:U" & Derlig)
    End With
    
    'ouverture de la datebase
    Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Export-eureka.xlsm" 'A ADAPTER
    With Sheets("data")
        For Cptr = 1 To UBound(T_ref)
            On Error GoTo inconnu
            Lig = Columns("B").Find(T_ref(Cptr), .Range("B2"), xlValues).Row
            For Col = 14 To 21
                .Cells(Lig, Col) = T_maj(Cptr, Col - 13)
            Next
        Next
    End With
    'sauvegarde et fermeture  export à voir
    
Exit Sub
'gestionnaire erreurs
inconnu:
    MsgBox " Reférence " & T_ref(Cptr) & " inconnue dans Export-Eureka !", vbCritical
End Sub


    Michel

    EDIT : Ajout du LANGAGE dans les balises de code.
    Explications disponibles ICI

    Merci d'y penser dans tes prochains messages.
    0
    1. vigie5656 Messages postés 9 Statut Membre
       
      Merci,
      C'est vraiment différent de ma proposition !
      Merci beaucoup, j'essaye ce code ce soir.
      Cdlt
      Chrsitophe
      0
    2. vigie5656 Messages postés 9 Statut Membre
       
      Michel, je viens de tester le code, ça marche.

      1 question :
      Je ne connais pas cette expression what:="*"... mais cela fonctionne, tu peux m'en dire plus pour ma culture.
      Derlig = .Columns("B").Find(what:="*", searchdirection:=xlPrevious).Row


      1 souci qui n'est pas bien grave, quand je n'ai qu'une ligne dans le tableau EUREKA Transfo, la fenêtre avec débogage apparait et la macro s'arrête, la ligne suivante est surligné en jaune
      For Cptr = 1 To UBound(T_ref)
      0
    3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      as tu bien copié
      option base 1
      ?
      pour find explication demain
      0
    4. vigie5656 Messages postés 9 Statut Membre
       
      Bonsoir,
      Oui, j'ai bien noté "Option Base 1"
      Je ne comprends pas.
      Cdlt
      Christophe
      0
  7. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour

    la macro modifiée 
    Option Explicit
    Option Base 1

    Sub ccm_maj()
    Dim Derlig As Integer, T_ref, T_maj
    Dim Cptr As Integer, Lig As Integer, Col As Byte, Nbre As Integer

        Application.ScreenUpdating = False 'fige l'écran: confort et rapidité
        
        'mémorisation des modifs
        With ThisWorkbook.Sheets("base")
            Derlig = .Columns("B").Find(what:="*", searchdirection:=xlPrevious).Row
            T_ref = .Range("B3:B" & Derlig)
            T_maj = .Range("N3:U" & Derlig)
            If Derlig = 3 Then
                Nbre = 1
            Else
                Nbre = UBound(T_ref)
            End If
        End With
        'ouverture de la datebase
        Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Export-eureka.xlsm" 'A ADAPTER
        With Sheets("data")
            For Cptr = 1 To Nbre
                If Nbre = 1 Then
                    Lig = Columns("B").Find(T_ref, .Range("B2"), xlValues).Row
                Else
                    Lig = Columns("B").Find(T_ref(Cptr), .Range("B2"), xlValues).Row
                End If
                For Col = 14 To 21
                    .Cells(Lig, Col) = T_maj(Cptr, Col - 13)
                Next
            Next
        End With
        'sauvegarde et fermeture  export à voir
        
    Exit Sub
    'gestionnaire erreurs
    inconnu:
        MsgBox " Reférence " & T_ref(Cptr) & " inconnue dans Export-Eureka !", vbCritical
    End Sub


    pour ta question

    "dans la colonne B trouve la dernière cellule avec quelque chose dedans (what), en remontant (xlprevious)"
    Il y en a d'autres mais c'est celle que je me souviens...
    0
    1. vigie5656 Messages postés 9 Statut Membre
       
      Merci pour tout
      Mon problème est résolu et j'ai progressé dans ma compréhension d'Excel.
      Cdlt
      Christophe
      0

Discussions similaires

Mises à jour tablette Samsung Galaxy tab2 GT-P5110
WalterP -
jelma2025 -

7 réponses
Table des matières dont les titres n'apparaissent pas..
Synua -
ggg -

10 réponses