rh.finances
XLDnaute Junior
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:
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
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