Copier/Coller d'un classeur dans un autre

Bonjour,

J'ai trouvé plein d'infos sur ce que je cherche, mais je n'arrive pas à faire quelque chose de simple.

Voilà, je souhaite, les deux classeurs étant dans le même répertoire,

  • à l'ouverture du classeur "destination" tester la présence du classeur "source" dans le répertoire.
  • si "source" est présent, copier le contenu de la feuille "a_copier" depuis la cellule A3, jusqu’à la dernière ligne et colonne utilisées
  • coller dans la cellule A4 de la feuille "a_coller" du classeur "destination"
(Si le classeur "source" pouvait rester fermé ça serait le top, mais je ne sais pas si c'est possible.)

1/ J'ai bien écrit quelques lignes de code, mais ça n'est vraiment pas top

2/ Ces deux fichiers sont simplifiés à l’extrême, les données à copier sont plus importantes..

3/ Il est important de partir d'une cellule donnée, car je ne tiens pas à copier toute la feuille.

Si une bonne fée pouvait se pencher sur mon cas, ça occuperait ce dimanche gris qui s'annonce

Merci !

11source.xlsm (8.32 Ko)
13destination.xlsm (8.02 Ko)

Bonjour BastLat,

Voilà un début de solution:

Public Sub copierValeurs(ByVal plageACopier As String, ByVal classeur1 As String, ByVal nomFeuille1 As String, ByVal celluleArrivee As String, ByVal classeur2 As String, ByVal nomFeuille2 As String)
Workbooks(classeur1).Activate
Workbooks(classeur1).Worksheets(nomFeuille1).Select
Workbooks(classeur1).Worksheets(nomFeuille1).Range(plageACopier).Select
Selection.Copy

Workbooks(classeur2).Activate
Workbooks(classeur2).Worksheets(nomFeuille2).Select
Workbooks(classeur2).Worksheets(nomFeuille2).Range(celluleArrivee).Select
ActiveSheet.Paste
End Sub

Public Sub main()

Call copierValeurs("A1:A25", "Classeur1", "Feuil1", "A2", "Classeur2", "Feuil2")
'A remplacer par ce que tu veux ;) 
End Sub

Function BookOpen(strBookName As String) As Boolean
    Dim oBk As Workbook
    On Error Resume Next
    Set oBk = Workbooks(strBookName)
    On Error GoTo 0
    If oBk Is Nothing Then
        BookOpen = False
    Else
        BookOpen = True
    End If
End Function

Voilà un code qui copie le contenue de: Classeur1->Feuil1->Cellules A1 à A25 vers Classeur2 -> Feuil2 -Cellule A2

Maintenant vis-à-vis de ce que tu cherches, il faut que tu crée un test dans la procédure Workbook_Open et y insérer ton test. Voilà un premier jet qui sera a priori non fonctionnel (à adapter) dans "ThisWorkbook':

Private Sub Workbook_Open()
if BookOpen("source.xlsm") then
call copierValeurs("A3:Z125","source.xlsm",etc........)

end if
End Sub

PS: La fonction pour tester l'ouverture d'un classeur n'est pas de moi ^^

Bref tiens moi au courant si ça pourrait te convenir

d3d9x a écrit :

Bonjour BastLat,

Voilà un début de solution.....

Bref tiens moi au courant si ça pourrait te convenir

Merci d3d9x ! J'ai adapté, et ça marche impeccablement bien !

Alors au risque d'abuser, pourrais tu m'indiquer, au moment ou on appelle:

Call copierValeurs("A1:A25", "source.xlsm", "a_copier", "A2", "destination.xlsm", "a_coller")

Comment demander dans [copierValeurs("A1:A25",...], non pas A25, mais la cellule qui correspond à la dernière ligne et de la dernière colonne utilisées de la feuille ?

J'utilise par exemple ceci pour déterminer la dernière ligne d'une feuille:

ligne = Range("D65536").End(xlUp).Offset(1, 0).Row

Mais après... Je cale

Voilà une version adaptée à ton besoin. Elle part de la case A1 jusqu'à la dernière cellule de la dernière ligne/colonne

Public Sub copierValeurs(ByVal classeur1 As String, ByVal nomFeuille1 As String, ByVal celluleArrivee As String, ByVal classeur2 As String, ByVal nomFeuille2 As String)

Dim lastLigne As Long
Dim lastColonne As Long

lastLigne = Range("D65536").End(xlUp).Offset(1, 0).Row
lastColonne = 25 ' <--------------- A CHANGER

Workbooks(classeur1).Activate
Workbooks(classeur1).Worksheets(nomFeuille1).Select
Workbooks(classeur1).Worksheets(nomFeuille1).Range(Cells(1, 1), Cells(lastLigne, lastColonne)).Select
Selection.Copy

Workbooks(classeur2).Activate
Workbooks(classeur2).Worksheets(nomFeuille2).Select
Workbooks(classeur2).Worksheets(nomFeuille2).Range(celluleArrivee).Select
ActiveSheet.Paste
End Sub

Public Sub main()

Call copierValeurs("Classeur1", "Feuil1", "A2", "Classeur2", "Feuil2")
'A remplacer par ce que tu veux ;)
End Sub

Il faut que tu édites le code pour calculer la dernière colonne!!!!!!!!!!!! (lastColonne = .......)

J'attends ton retour

d3d9x a écrit :

Voilà une version adaptée à ton besoin. .....

J'attends ton retour

Et bien voici mon retour

J'ai un peu modifié et simplifié (pour moi...)

Et ça fonctionne impec !

Je vérifie qu'un fichier Source est présent dans le même répertoire:

Sub outhé()

Dim Msg, Title
Dim Path_name As String
Dim File_name As String
Dim Complete_File_name As String

Title = "Mise à Jour possible "    ' Définit le titre.

File_name = "fichier_source.xlsm"
Path_name = ThisWorkbook.Path
Complete_File_name = Path_name & "\" & File_name
Msg = "Un fichier nommé:" & Chr(10) & "[" & File_name & "]" & Chr(10) & _
"existe dans ce répertoire." & Chr(10) & Chr(10) & _
"Souhaitez vous effectuer une mise à jour ?"

Dim rep As Integer

    rep = msgbox(Msg, vbYesNo + vbQuestion, Title)
    If rep = vbYes Then
        ' ici le traitement si réponse positive
        Call MaJ
    Else
        ' ici le traitement si réponse négative
    End If

End If

End Sub

S'il est présent, et que l'utilisateur souhaite faire une mise à jour, je lance la Sub MaJ:

Sub MaJ()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call copierValeurs("A3:D8", "fichier_source.xlsm", "feuille_source", "A1", "fichier_destination.xlsm", "feuille_destination")
'Appel d'autres procédures..
Application.DisplayAlerts = True
Application.ScreenUpdating = True
msgbox ("Préparation du tableau terminée")
End Sub

Qui elle même appelle la copie de la plage:

Public Sub copierValeurs(ByVal plageACopier As String, _
ByVal classeur1 As String, _
ByVal nomFeuille1 As String, _
ByVal celluleArrivee As String, _
ByVal classeur2 As String, _
ByVal nomFeuille2 As String)

Dim NomFich
Dim DerLig As Long
Dim DerCol As Long

Adresse = ThisWorkbook.Path
NomFich = classeur1
Workbooks.Open Filename:=Adresse & "\" & NomFich

Workbooks(classeur1).Activate
Workbooks(classeur1).Worksheets(nomFeuille1).Select

With Workbooks(classeur1).Worksheets(nomFeuille1)
        DerLig = .Cells.SpecialCells(xlCellTypeLastCell).Row
        DerCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
End With

Workbooks(classeur1).Worksheets(nomFeuille1).Range(("A18"), Cells(DerLig, DerCol)).Select
Selection.Copy

Workbooks(classeur2).Activate
Workbooks(classeur2).Worksheets(nomFeuille2).Select
Workbooks(classeur2).Worksheets(nomFeuille2).Range(celluleArrivee).Select
ActiveSheet.Paste
Workbooks(classeur1).Close
End Sub

Merci pour ton aide.

(je pense que ça doit vous faire sourire, mais pour moi, c'était une MONTAGNE )

Rechercher des sujets similaires à "copier coller classeur"