J'essaie de copier des données de 7 feuilles de calcul différentes (dans le même classeur) dans une feuille de calcul appelée Combine [duplicate]

Dec 23 2020

J'essaie de copier des données de 7 feuilles de calcul différentes (dans le même classeur) dans une feuille de calcul appelée Combine. J'ai également besoin d'une feuille appelée «Résumé» pour ne pas être copiée. puis, une fois les 7 feuilles de calcul copiées, elles doivent être supprimées.

C'est ce que j'ai obtenu jusqu'à présent, mais il ne copie que la feuille de calcul ACT

Sub Combine()

    Dim s As Worksheet, wb As Workbook, wsDest As Worksheet, rngCopy As Range

    Set wb = ActiveWorkbook  ' always specify a workbook

    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets("ACT").Delete 'These sheets don't need to be kept or consolidated
    wb.Sheets("VIC").Delete
    wb.Sheets("NSW").Delete
    wb.Sheets("QLD").Delete
    wb.Sheets("NT").Delete
    wb.Sheets("SA").Delete
    wb.Sheets("WA").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'get a direct reference to the newly-added sheet
    Set wsDest = wb.Worksheets.Add(before:=wb.Worksheets(1))
    wsDest.Name = "Combine"

    wb.Sheets(2).Range("A1").EntireRow.Copy Destination:=wsDest.Range("A1")

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> "Summary" Then    ' remove hard-coded name
            Set rngCopy = s.Range("A1").CurrentRegion
            'check how many rows before copying
            If rngCopy.Rows.Count > 1 Then
                'no need for select/activate
                rngCopy.Offset(1, 0).Resize(rngCopy.Rows.Count - 1).Copy _
                   wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
        End If
    Next s
End Sub



Réponses

Tomasz Dec 23 2020 at 15:56

essayez ci-dessous le code, l'édition est marquée.

Sub Combine()
Dim rngCopy As Range                        '<< edited visual
Dim wb As Workbook                          '<< edited visual
Dim s As Worksheet, wsDest As Worksheet     '<< edited visual

Application.DisplayAlerts = False   '<< edited
Application.EnableEvents = False    '<< edited
Application.ScreenUpdating = False  '<< edited

Set wb = ThisWorkbook  '<< edited
'get a direct reference to the newly-added sheet
Set wsDest = wb.Worksheets.Add(before:=wb.Worksheets(1))    '<< edited visual
wsDest.Name = "Combine"                                     '<< edited visual
wb.Worksheets(2).Rows(1).EntireRow.Copy Destination:=wsDest.Range("A1")         '<< edited

For Each s In wb.Worksheets     '<< edited
    If s.Name = "ACT" Or s.Name = "VIC" Or s.Name = "NSW" Or _
        s.Name = "QLD" Or s.Name = "NT" Or s.Name = "SA" Or s.Name = "WA" Then  '<< edited
        s.Delete                                                                '<< edited
    ElseIf s.Name <> "Summary" Then    '<< remove hard-coded name
        Set rngCopy = s.Range("A1").CurrentRegion
        'check how many rows before copying
        If rngCopy.Rows.Count > 1 Then
            'no need for select/activate
            rngCopy.Offset(1, 0).Resize(rngCopy.Rows.Count - 1).Copy _
            wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    End If
Next s

Application.DisplayAlerts = True    '<< edited
Application.EnableEvents = True     '<< edited
Application.ScreenUpdating = True   '<< edited
End Sub