Как я могу скопировать из Speci c Shett в Excel

Question

Я пытаюсь объединить несколько листов в один лист, и я использовал следующий код VBA:

Sub Combine()
    Dim J As Integer
    Dim s As Worksheet

    On Error Resume Next
    Sheets("Operational").Activate
    Range("A1:A2").EntireRow.Select
    Selection.Copy Destination:=Sheets("Combined").Range("A1:A2")

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> "Combined" And _
           s.Name <> "Probability & Impact" And _
           s.Name <> "Escalation Criteria" And _
           s.Name <> "Application list" And _
           s.Name <> "Dashboard" Then
            Application.GoTo Sheets(s.Name).[a1]
            Selection.CurrentRegion.Select
            ' Don't copy the headings
            Selection.Offset(2, 0).Resize(Selection.Rows.Count - 1).Select
            Selection.Copy Destination:=Sheets("Combined"). _
              Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
      Sheets("Combined").Activate
End Sub

Файл содержит много вкладок, и мне нужно только объединить 4 листа в один, называемый (Combain) , Проблема в том, что последний лист был скопирован три раза. есть какое-то решение для этого?

Answer 1

Попробуйте этот фрагмент кода, пожалуйста: он должен работать быстрее, чем вы пытались, избегая выбора.

Sub Combine()
    Dim J As Integer, curReg As Range, arrCR As Variant
    Dim s As Worksheet, shComb As Worksheet, lastCombR As Long

    Set shComb = Sheets("Combined")

    Sheets("Operational").Range("A1:A2").EntireRow.Copy _
                            Destination:=shComb.Range("A1:A2")

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> "Combined" And s.Name <> "Probability & Impact" And _
           s.Name <> "Escalation Criteria" And s.Name <> "Application list" And _
                                                     s.Name <> "Dashboard" Then
            Set curReg = s.Range("A1").CurrentRegion
            If curReg.Rows.count = 1 And curReg.Columns.count = 1 Then
                 MsgBox "Sheet """ & s.Name & """ does not have appropriate records to be copied..."
            Else
                arrCR = curReg.Offset(2, 0).Resize(curReg.Rows.count - 1).Value
                lastCombR = shComb.Cells(shComb.Rows.count, 1).End(xlUp)(2).Row
                shComb.Range(shComb.Cells(lastCombR, "A"), _
                    shComb.Cells(lastCombR + UBound(arrCR, 1) - 1, _
                                      UBound(arrCR, 2))).Value = arrCR
            End If
        End If
    Next
      shComb.Activate
End Sub

Вы можете активировать «Комбинированный» лист с самого начала, видя, что происходит. Нет необходимости активировать «Операционный» лист, больше ...