Mettre a jour des données sur 2 fichiers

Résolu
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention   -  
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention   -
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.
A voir également:

6 réponses

Réponse 1 / 6
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
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
vigie5656
 
Merci Michel
Ci-joint le lien : http://www.cjoint.com/c/EIeoBOpfiWK
Merci
0
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314 > vigie5656
 
Ok, merci, sois patient !
je m'occuperai de çà demain ou après-demain !
0
vigie5656 > michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention  
 
Merci super, si tu peux demain c'est génial.
0
Réponse 2 / 6
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
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
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
Merci Michel pour to aide

Le fichier "EUREKA-Transfo.xlsm" disponible ici:
https://www.cjoint.com/c/EIgngxVlNvu


Le document "Export-eureka.xlsm" disponible ici:
https://www.cjoint.com/c/EIgngR6biRu

Voilà ces 2 classeurs non zippés.

Cdlt
0
Réponse 3 / 6
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
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
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
Ok, 2 nouvelles tentatives :

Le lien a été crée : https://www.cjoint.com/c/EIhi7YQ8YkK
Le lien a été crée : https://www.cjoint.com/c/EIhjaHs8N2K

Si non ok,, tu peux me communiquer une autre adresse ? Mon e-mail : adresse email modérée

cdlt
Christophe
0
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
Re bonjour,
Je viens d'utiliser We transfert, et là ça fonctionne.
Le lien : http://we.tl/qwUWHgd5Le

Cdlt
0
Réponse 4 / 6
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
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

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

Posez votre question
Réponse 5 / 6
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
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
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
Merci,
C'est vraiment différent de ma proposition !
Merci beaucoup, j'essaye ce code ce soir.
Cdlt
Chrsitophe
0
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
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
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
as tu bien copié
option base 1
?
pour find explication demain
0
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
Bonsoir,
Oui, j'ai bien noté "Option Base 1"
Je ne comprends pas.
Cdlt
Christophe
0
Réponse 6 / 6
michel_m Messages postés 16602 Date d'inscription   Statut Contributeur Dernière intervention   3 314
 
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
vigie5656 Messages postés 9 Date d'inscription   Statut Membre Dernière intervention  
 
Merci pour tout
Mon problème est résolu et j'ai progressé dans ma compréhension d'Excel.
Cdlt
Christophe
0

Discussions similaires

mise à jour boitier X96 mini
Brunoche -
Vico -

3 réponses
Mises à jour tablette Samsung Galaxy tab2 GT-P5110
WalterP -
WalterP -

6 réponses