Copier/coller plusieurs cellules/pages d'un classeur sur un autre

Bonjour,

comme indiqué dans le titre j'ai besoin d'aide pour rédiger un code qui puisse copier différentes cellules de différentes pages d'un classeur et de les coller vers une nouvelle page créer sur un autre classeur .(j'espère être assez clair ?), ca me permettra de faire des synthèse pour mon job.

Ci-joint un code que j'utilise pour copier/coller certaines cellules d'une page d'un classeur pour en créer une nouvelle sur un autre, peut être est il possible de l'améliorer pour accéder au sujet de ma demande.

(je suis vraiment débutant en VBA)

Merci d'avance pour votre aide, la tache n'est pas aisée...

Sub CopierCollerdernier()

  Dim WbkSource As Workbook, WbkDest As Workbook
  Dim PlageACopier As Range, Plg As Range, TabDRng, TabSRng
  Dim IndRng As Integer

  ' Définir le classeur source
  Set WbkSource = ThisWorkbook
  '
  ' Ouvrir le classeur de destination ICI
  Set WbkDest = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\Avancement_travaux.xlsm")

  ' Créer une nouvelle feuille
  WbkDest.Sheets.Add After:=WbkDest.Sheets(WbkDest.Sheets.Count)
  NomFeuille = InputBox("Quel nom voulez vous donner à la feuille ?", "NOM FEUILLE")
  If NomFeuille <> "" Then
    WbkDest.ActiveSheet.Name = NomFeuille
  End If

  ' Mettre les plages à copier dans un tableau Source
  TabSRng = Split("P1:P2,Q1:Q2,G3:I22,G32:I45,N3:P24,N40:P47,U3:W10,U17:W22,U32:W47,AB3:AD10,AB25:AD34,AB41:AD48", ",")
  ' Mettre les plages à coller dans un tableau Destination
  TabDRng = Split("G1,j1,B3,B23,E3,E25,H3,H11,H17,K3,K11,K21", ",")
  ' Pour chaque plage à copier du tableau
  For IndRng = 0 To UBound(TabSRng)
    'Définir la plage à copier
    Set PlageACopier = WbkSource.ActiveSheet.Range(TabSRng(IndRng))
    ' Copier la plage source
    PlageACopier.Copy
    ' La coller avec valeur et format
    With WbkDest.ActiveSheet
      With .Range(TabDRng(IndRng))
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=8
      End With
    End With
  Next IndRng
  ' Fermer et enregistrer le classeur
  ' WbkDest.Close SaveChanges:=True
  ' Effacer les variables objet pour libérer la mémoire
  Set WbkDest = Nothing: Set PlageACopier = Nothing: Set WbkSource = Nothing

' CADRENOIR Macro
    Windows("Avancement_travaux.xlsm").Activate
    Range("B3:D36").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Range("G1:J1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("G2:J2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("E3:G32").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Range("H3:J32").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Range("K3:M28").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

Bonjour Stéphanek

Je ne vois pas ce que vous voulez de plus votre macro doit faire son job

A+

Bonjour,

le code que je vous ai présenté ne copie les cellules que d'une seul pages du classeur.

Cordialement.

Bonjour,

Personne pour m'aider ?

S'il vous plait.

j'ai trouvé se code qui fonctionne très bien et que j'ai modifié mais j'aimerais pouvoir copier les 5 onglets qui se positionne avant ma feuille active ainsi que certaine cellule pour les copier sur mon classeur "Avancement_travaux.xlsm" . merci.

Sub Copie_de_certaines_feuilles_et_cellules()

  Dim WbkSource As Workbook, WbkDest As Workbook
  Dim LaFeuille As Worksheet

Application.ScreenUpdating = False

' Définir le classeur source
Set WbkSource = ThisWorkbook
' Ouvrir le classeur de destination
Set WbkDest = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\Avancement_travaux.xlsm")

    For Each LaFeuille In WbkSource.Worksheets
       If MsgBox("Copier la feuille " & LaFeuille.Name, vbYesNo) = vbYes Then _
LaFeuille.Copy After:=WbkDest.Worksheets(WbkDest.Worksheets.Count)
    Next

Set WbkSource = Nothing
Set WbkDest = Nothing

Application.ScreenUpdating = True

End Sub