vba:Copier feuil entre classeurs differents Résolu

Question

Bonjour à toutes et à tous,

Je cherche à copier 2 feuilles d'un classeur A et 2  feuilles d'un classeur B vers un troisieme classeur.

J'ai trouvé des codes VBA sur info3000 "Synthèse  de plusieurs classeurs", j'ai adapté sur excel 2003.

Mais l'exemple concerne 4 classeurs identiques, moi je n'ai que deux classeurs. Les feuil1 se collent à la suite comme prévu par contre je n'arrive pas à intégrer les feuilles 2.

Je vous indique le Début du code qui fonctionne :

Sub Recapsynthese()
Cells.Delete
'Titre Colonne
    Range("A1") = "Société juridique"
    Range("B1") = "Société de Gestion"
    Range("C1") = "Fournisseur"
    
 'Mise en forme
    
    Range("A1:C1").Interior.Color = 13434879
    Range("A1:C1").Font.Bold = True
 'Ouvrir Classeur

    Workbooks.Open "O:\DD\PILOT BUDGETAIRE\PILOT FACT\2012\FLUX FIN\COMMANDE 2012\COMMANDE FLUX FIN 2012.XLS"
    DerniereLigne = ActiveSheet.UsedRange.Rows.Count
    Range("A18:AC" & DerniereLigne).Copy
    Workbooks("Recapsynthese.xls").Activate
    DebutNomFichier = ActiveSheet.UsedRange.Rows.Count
    Range("B" & ActiveSheet.UsedRange.Rows.Count + 1).Select
    ActiveSheet.Paste
    Range("A" & DebutNomFichier & ":A" & ActiveSheet.UsedRange.Rows.Count) = ("FLUX FIN")
    Workbooks("COMMANDE FLUX FIN 2012.xls").Close
    
    Workbooks.Open "O:\DDOP\PILOTAGE BUDGETAIRE\PILOTAGE FACTURATION\2012\FLUX FINANCIERS\COMMANDE 2012\COMMANDE SUPPORT  2012.XLS"
    DerniereLigne = ActiveSheet.UsedRange.Rows.Count
    Range("A18:AC" & DerniereLigne).Copy
    Workbooks("Recapsynthese.xls").Activate
    
    DebutNomFichier = ActiveSheet.UsedRange.Rows.Count + 1
    Workbooks("Recapsynthese.xls").Sheets("Feuil1").Range("B" & ActiveSheet.UsedRange.Rows.Count + 1).Select
    ActiveSheet.Paste
    Range("A" & DebutNomFichier & ":A" & ActiveSheet.UsedRange.Rows.Count) = "SUPPORT "
    Workbooks("COMMANDE SUPPORT 2012.xls").Close


Par avance merci
Charlyjack 



Configuration: Windows XP / Internet Explorer 7.0

Patrice33740 · Answer

Bonjour,

Je ne l'ai pas essayé, mais ce code devrait convenir:

Sub Recapsynthese()
Dim wbkSource As Workbook
Dim wshSource As Worksheet
Dim wshCible As Worksheet

Set wshCible = ActiveSheet
wshCible.Cells.Delete
'Titre Colonne
wshCible.Range("A1") = "Société juridique"
wshCible.Range("B1") = "Société de Gestion"
wshCible.Range("C1") = "Fournisseur"

'Mise en forme
wshCible.Range("A1:C1").Interior.Color = 13434879
wshCible.Range("A1:C1").Font.Bold = True

'Ouvrir Classeur 1
DebutNomFichier = wshCible.UsedRange.Rows.Count
Set wbkSource = Workbooks.Open("O:\DD\PILOT BUDGETAIRE\PILOT FACT\2012\FLUX FIN\COMMANDE 2012\COMMANDE FLUX FIN 2012.XLS")
Set wshSource = wbkSource.Worksheets(1)
DerniereLigne = wshSource.UsedRange.Rows.Count
wshSource.Range("A18:AC" & DerniereLigne).Copy wshCible.Range("B" & wshCible.UsedRange.Rows.Count + 1)
wshCible.Range("A" & DebutNomFichier & ":A" & wshCible.UsedRange.Rows.Count) = ("FLUX FIN")
wshSource.Close

'Ouvrir Classeur 2
DebutNomFichier = wshCible.UsedRange.Rows.Count
Set wbkSource = Workbooks.Open("O:\DDOP\PILOTAGE BUDGETAIRE\PILOTAGE FACTURATION\2012\FLUX FINANCIERS\COMMANDE 2012\COMMANDE SUPPORT 2012.XLS")
Set wshSource = wbkSource.Worksheets(1)
DerniereLigne = wshSource.UsedRange.Rows.Count
wshSource.Range("A18:AC" & DerniereLigne).Copy wshCible.Range("B" & wshCible.UsedRange.Rows.Count + 1)
wshCible.Range("A" & DebutNomFichier & ":A" & wshCible.UsedRange.Rows.Count) = ("SUPPORT ")
wshSource.Close

End Sub

Vba:Copier feuil entre classeurs differents

1 réponse

Discussions similaires

Newsletters