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

将单元格范围从多张纸复制到一张

1 个答案: