Скопируйте диапазон ячеек из нескольких листов в один

Question

Я пытаюсь скопировать определенный диапазон ячеек из пяти разных листов и объединить их в один лист, все они вставляются прямо друг под другом.Мне удалось скопировать и вставить весь лист, но как мне установить определенный диапазон и прокрутить каждый лист в одной и той же книге?

Sub Button1_Click()
Dim CopyFrom As Object
Dim CopyTo As Object ''Early binding: Workbook
Dim CopyThis As Object
Dim xl As Object ''Early binding: New Excel.Application

''Late binding
Set xl = CreateObject("Excel.Application")
xl.Visible = True

''To use a password: Workbooks.Open Filename:="Filename", Password:="Password"
Set CopyFrom = xl.Workbooks.Open("I:\Gamers\PMO Automation\New Initiative Template v1_30_2019.xlsm")
Set CopyThis = CopyFrom.Sheets(2) ''Sheet number 1
Set CopyTo = xl.Workbooks.Open("I:\Gamers\PMO Automation\PMO Automation.xlsm")
CopyThis.Copy After:=CopyTo.Sheets(CopyTo.Sheets.Count)

CopyFrom.Close False
End Sub

Answer 1

Попробуйте, это должно работать:

    Sub RunIT()
        CopyPasteRangeFromWorkBooks "A1:A5"
    End Sub

    Sub CopyPasteRangeFromWorkBooks(strInRange As String)
        Dim CopyFrom As Object
        Dim CopyTo As Object ''Early binding: Workbook
        Dim xl As Object ''Early binding: New Excel.Application
        Dim rngCopy As Object
        Dim rngPaste As Object
        Dim sht As Object
        Dim intCnt As Integer
        Dim strName As String

        ''Late binding
        Set xl = CreateObject("Excel.Application")
        xl.Visible = True

        Set rngUnion = Nothing

    'To use a password: Workbooks.Open Filename:="Filename", Password:="Password"
    Set CopyFrom = xl.Workbooks.Open("I:\Gamers\PMO Automation\New Initiative Template v1_30_2019.xlsm")

        intCnt = 0
        For Each sht In CopyFrom.Worksheets
            Set rngCopy = sht.Range(strInRange)
            rngCopy.Copy

            If intCnt < 1 Then
                'paste will have to go here    '"I:\Gamers\PMO Automation\PMO Automation.xlsm"
                Set CopyTo = xl.Workbooks.Open("I:\Gamers\PMO Automation\PMO Automation.xlsm")

                CopyTo.Worksheets.Add

                strName = CopyTo.Worksheets(CopyTo.Worksheets.Count).Name
                Set rngPaste = CopyTo.Worksheets(strName).Range("A1")

                rngPaste.PasteSpecial Paste:=xlPasteAll

                intCnt = intCnt + rngCopy.Rows.Count + 1
            Else
                Set rngPaste = CopyTo.Worksheets(strName).Range("A" & intCnt)

                rngPaste.PasteSpecial Paste:=xlPasteAll

                intCnt = intCnt + rngCopy.Rows.Count
            End If
        Next


    '    CopyTo.Close
    '    CopyFrom.Close
    '
    '    xl.Quit

        Set rngCopy = Nothing
        Set rngUnion = Nothing
        Set CopyFrom = Nothing
        Set CopyTo = Nothing
        Set xl = Nothing
    End Sub