Regrouper plusieurs feuilles en 1

salut à tous ,

j'ai trouvé ce code sur le net et je veux l'adapter à ma situation ... il s'agit d'un code qui regroupe les données des feuilles dans une seule feuille nomée "cumul" en supprimant la feuille "cumul" si elle existe et et la créer de nouveau.

Moi je veux que la feuille cumul soit toujours existante je veux supprimer l'action du suppression / création dans ce code.

merci de votre aide

Sub regrouper()

Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

  'Delete the sheet "cumul" if it exist....... ((((( Je veux enlever cette partie )))))
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("cumul").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "cumul"  ((((( Je veux enlever cette partie )))))
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "cumul"

    'Fill in the start row
    StartRow = 2

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
  sh.Range("A1:I2").Copy DestSh.Range("A1")
End If
            'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then

                'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

                'Test if there enough rows in the DestSh to copy all the data
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "There are not enough rows in the Destsh"
                    GoTo ExitTheSub
                End If

                'This example copies values/formats, if you only want to copy the
                'values or want to copy everything look below example 1 on this page
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    Next

ExitTheSub:

    Application.GoTo DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

        End Sub

Bonjour

Attention pas testée (code incomplet)

Sub regrouper()

Dim sh As Worksheet 
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

'  'Delete the sheet "cumul" if it exist....... ((((( Je veux enlever cette partie )))))
'   Application.DisplayAlerts = False
'    On Error Resume Next
'    ActiveWorkbook.Worksheets("cumul").Delete
'    On Error GoTo 0
'    Application.DisplayAlerts = True
'
'    'Add a worksheet with the name "cumul"  ((((( Je veux enlever cette partie )))))
'   Set DestSh = ActiveWorkbook.Worksheets.Add
'    DestSh.Name = "cumul"

 Set DestSh = Sheets("cumul")
  'Fill in the start row
   StartRow = 2

  'loop through all worksheets and copy the data to the DestSh
  For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
      'Copy header row, change the range if you use more columns
      If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
        sh.Range("A1:I2").Copy DestSh.Range("A1")
      End If
      'Find the last row with data on the DestSh and sh
      Last = LastRow(DestSh)
      shLast = LastRow(sh)
      'If sh is not empty and if the last row >= StartRow copy the CopyRng
       If shLast > 0 And shLast >= StartRow Then

        'Set the range that you want to copy
        Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

        'Test if there enough rows in the DestSh to copy all the data
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
          MsgBox "There are not enough rows in the Destsh"
          GoTo ExitTheSub
        End If

        'This example copies values/formats, if you only want to copy the
        'values or want to copy everything look below example 1 on this page
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
          .PasteSpecial xlPasteValues
          .PasteSpecial xlPasteFormats
          Application.CutCopyMode = False
        End With

      End If

    End If
  Next

ExitTheSub:

  Application.GoTo DestSh.Cells(1)
  'AutoFit the column width in the DestSh sheet
  DestSh.Columns.AutoFit

  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With

End Sub

merci pour la réponse. j'ai trouvé la solution c'est comme ci-dessous.

Set DestSh = Sheets("cumul")
    DestSh.Name = "cumul"    
    Sheets("cumul").Range("A2:AX6000").ClearContents

Bonsoir

Tu n'avais pas précisé que tu voulais aussi effacer la page

juste pour simplifier

Set DestSh = Sheets("cumul")
   ' DestSh.Name = "cumul"    ' Instruction inutile ta page s'appelle déjà "cumul"
    Sheets("cumul").Range("A2:AX6000").ClearContents