retranscription de données sur 2 classeurs différents

rh.finances · 15 Novembre 2009

bonsoir à tous les internautes de ce forum,

je sollicite votre aide concernant un problème de retranscription de données.
je dispose de données sur un classeur (voir fichier joint) et mon but est de retranscrire ces données sur 1 classeur lorsque la mention dans la colonne D indique "Entrée" et à retranscrire ces même données sur un autre classeur lorsque la colonne D indique "Sortie".

je me suis inspiré d'un code trouvé sur ce site et déposé par kjin (voir lien suivant: https://www.excel-downloads.com/threads/retranscription-de-donnees-vers-autre-classeur.101692/). ce code permet de retranscrire des données sur un seul tableau:

Code:

Private Sub CommandButton1_Click()
Dim Quest As Integer
Dim Repertoire As String
Dim FichDest As String
Dim FichSource As String
Dim NouvFeuil As String
Dim Trouve As Boolean
Dim IntWS As Integer
    Application.ScreenUpdating = False
    Quest = MsgBox("Etes-vous sûr de vouloir enregistrer la Feuille ?", vbYesNo + vbQuestion)
    If Quest = vbNo Then Exit Sub
    If Quest = vbYes Then
    Repertoire = ActiveWorkbook.Path & "\" 'changer le chemin ici
    FichDest = "T2.xls" 'changer le nom ici
    FichSource = ThisWorkbook.Name
        If ActiveSheet.Range("A1").Value <> vbNullString Then
        NouvFeuil = ActiveSheet.Range("A1").Value
        End If
    Workbooks.Open Repertoire & FichDest
    Windows(FichDest).Activate
    Trouve = False
        For IntWS = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(IntWS).Name = NouvFeuil Then
                Trouve = True
                Windows(FichSource).Activate
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest).Sheets(NouvFeuil).Range("B65000").End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
                Exit For
            End If
        Next IntWS
            If Trouve = False Then
                ActiveWorkbook.Sheets.Add , After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = NouvFeuil
                Windows(FichSource).Activate
                ActiveSheet.Range("B7:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest).Sheets(NouvFeuil).Range("B3")
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
            End If
        Application.DisplayAlerts = False
        Workbooks(FichDest).Save
        Workbooks(FichDest).Close
            
    Application.ScreenUpdating = True
    End If

End Sub

j'ai essayé de modifier ce code à ma façon (c'est à dire comme quelqu'un qui patauge complètement en langage VB... 🙁) et à plusieurs reprises. mais rien ne marche. j'ai une "erreur d'exécution 13".

si quelqu'un saurait me venir en aide, ce serait vraiment super!!!! 🙂
le code que j'ai essayé de construire est le suivant.
merci d'avance

Alex

Code:

Private Sub CommandButton1_Click()
Dim Quest As Integer
Dim Repertoire As String
Dim FichDest1 As String
Dim FichDest2 As String
Dim FichSource As String
Dim NouvFeuil As String
Dim Trouve As Boolean
Dim IntWS As Integer
    Application.ScreenUpdating = False
    Quest = MsgBox("Etes-vous sûr de vouloir enregistrer la Feuille ?", vbYesNo + vbQuestion)
    If Quest = vbNo Then Exit Sub
    If Quest = vbYes Then
    Repertoire = ActiveWorkbook.Path & "\" 'changer le chemin ici
    FichDest1 = "ENTREE10.xls" 'changer le nom ici
    FichDest2 = "SORTIE10.xls" 'changer le nom ici
    FichSource = ThisWorkbook.Name
        If ActiveSheet.Range("A1").Value <> vbNullString Then
        NouvFeuil = ActiveSheet.Range("A1").Value
        End If
    
       
If ActiveSheet.Range("d8:d65000").Value = "Entrée" Then
    Workbooks.Open Repertoire & FichDest1
    Windows(FichDest1).Activate
    Trouve = False
        For IntWS = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(IntWS).Name = NouvFeuil Then
                Trouve = True
                Windows(FichSource).Activate
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest1).Sheets(NouvFeuil).Range("B65000").End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest1).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
                Exit For
            End If
        Next IntWS
            If Trouve = False Then
                ActiveWorkbook.Sheets.Add , After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = NouvFeuil
                Windows(FichSource).Activate
                ActiveSheet.Range("B7:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest1).Sheets(NouvFeuil).Range("B3")
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest1).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
            End If
        Application.DisplayAlerts = False
        Workbooks(FichDest1).Save
        Workbooks(FichDest1).Close
            
    Application.ScreenUpdating = True
    End If
End If

If ActiveSheet.Range("d8:d65000").Value = "Sortie" Then
    Workbooks.Open Repertoire & FichDest2
    Windows(FichDest2).Activate
    Trouve = False
        For IntWS = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(IntWS).Name = NouvFeuil Then
                Trouve = True
                Windows(FichSource).Activate
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest2).Sheets(NouvFeuil).Range("B65000").End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest2).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
                Exit For
            End If
        Next IntWS
            If Trouve = False Then
                ActiveWorkbook.Sheets.Add , After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = NouvFeuil
                Windows(FichSource).Activate
                ActiveSheet.Range("B7:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest2).Sheets(NouvFeuil).Range("B3")
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest1).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
            End If
        Application.DisplayAlerts = False
        Workbooks(FichDest2).Save
        Workbooks(FichDest2).Close
            
    Application.ScreenUpdating = True
    End If
    

End Sub

jp14 · 17 Novembre 2009

Re : retranscription de données sur 2 classeurs différents

Bonjour

Ci joint un fichier avec une procédure à tester.

JP

rh.finances · 19 Novembre 2009

Re : retranscription de données sur 2 classeurs différents

bonjour JP, bonjour à tout le forum,

une nouvelle fois merci beaucoup de me venir en aide JP 🙂
j'ai testé ton modèle et je rencontre quelques soucis.les informations dans le classeur 1 ne disparaissent pas au moment de la validation de l'archivage (j'ai essayé d'indiquer la mention "clearcontents" dans les codes... mais j'ai eu un message d'erreur). et par ailleurs, je ne comprends, mais je n'arrive pas du tout à ouvrir les classeurs entrée et sortie. j'ai beau cliquer plusieurs fois, rien ne se passe 😕

dois je utiliser le fichier d'une façon bien particulière?

merci

Alex

jp14 · 19 Novembre 2009

Re : retranscription de données sur 2 classeurs différents

Bonjour rh.finances

Pour effacer il faut écrire en dessous de l'écriture le code suivant

Code:

Workbooks(classeur).Sheets(FichSource).Range("B" & cellule.Row & ":F" & cellule.Row).ClearContents

Les fichiers sont ouverts, pour les voir il faut utiliser "afficher" du menu fenêtre.

JP

rh.finances · 19 Novembre 2009

Re : retranscription de données sur 2 classeurs différents

bonsoir JP14,

et une nouvelle fois, merci pour ton aide 😉!!
j'ai suivi tes instructions à la lettre.
si je ne me trompe pas: une fois que j'ai validé le mouvement de stock, il faut d'abord que je clique sur le classeur "entrée" ou "sortie". c'est uniquement à ce moment là que je reviens dans le classeur 1 et que je fais "afficher" (car, je sais pas si c'est normal, une fois que j'ai validé mon mouvement de stock, je ne peux pas cliquer directement sur "afficher",l'onglet est grisé. il faut que je clique d'abord sur les classeurs entrée ou sortie).

enfin, j'ai essayé d'appliquer clearcontents dans le code:
au début, je placé ton code en dessous de :

Code:

For Each cellule In Range("b8:b" & Workbooks(classeur).Sheets(FichSource).Range("b65536").End(xlUp).Row

la disparition des données marchaient mais la retranscription sur les feuilles entrée ou sortie ne marchait plus.
j'ai alors tenté de placer le code avant "End Select" ou après " Application.ScreenUpdating = True"... mais j'ai eu à chaque fois un message d'erreur.

Suis vraiment désolé... suis vraiment pas bon en langage VB 😱

encore merci

Alex

jp14 · 19 Novembre 2009

Re : retranscription de données sur 2 classeurs différents

Bonsoir

Normalement les fichiers entrée et sorties sont ouvert et fermé par la macro, la procédure avant de les ouvrir, vérifie s'ils ne sont pas déjà ouvert pour éviter une erreur.
En de procédure la macro les ferme.

Ci dessous la partie du code à modifier

Code:

Select Case cellule.Offset(0, 2)
        Case "Entrée"
        dl1 = Workbooks(FichDest1).Sheets(1).Range("b65536").End(xlUp).Row + 1
            Workbooks(classeur).Sheets(FichSource).Rows(cellule.Row).Copy _
             Destination:=Workbooks(FichDest1).Sheets(1).Rows(dl1)
            [COLOR="Red"]Workbooks(classeur).Sheets(FichSource).Range("B" & cellule.Row & ":F" & cellule.Row).ClearContents[/COLOR]
        Case "Sortie"
         dl1 = Workbooks(FichDest2).Sheets(1).Range("b65536").End(xlUp).Row + 1
            Workbooks(classeur).Sheets(FichSource).Rows(cellule.Row).Copy _
             Destination:=Workbooks(FichDest2).Sheets(1).Rows(dl1)
            [COLOR="Red"]Workbooks(classeur).Sheets(FichSource).Range("B" & cellule.Row & ":F" & cellule.Row).ClearContents[/COLOR]
   End Select

bonne soirée

JP

rh.finances · 22 Novembre 2009

Re : retranscription de données sur 2 classeurs différents

Bonjour JP,

excuse moi pour ma réponse un peu tardive.
j'ai essayé ta modification de macro!! c'est nickel 🙂
un nouvelle fois (une énième fois), MERCI POUR TOUT !!!
Tu m'as vraiment bien aidé sur ce projet.
Mille fois merci pour ta collaboration!! 🙂

Alex

retranscription de données sur 2 classeurs différents

rh.finances

XLDnaute Occasionnel

Pièces jointes

jp14

XLDnaute Barbatruc

Pièces jointes

rh.finances

XLDnaute Occasionnel

jp14

XLDnaute Barbatruc

rh.finances

XLDnaute Occasionnel

jp14

XLDnaute Barbatruc

rh.finances

XLDnaute Occasionnel

Discussions similaires

retranscription de données sur 2 classeurs différents

rh.finances

XLDnaute Occasionnel

Pièces jointes

jp14

XLDnaute Barbatruc

Pièces jointes

rh.finances

XLDnaute Occasionnel

jp14

XLDnaute Barbatruc

rh.finances

XLDnaute Occasionnel

jp14

XLDnaute Barbatruc

rh.finances

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency