代码之家 › 专栏 › 技术社区 › Chris

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

vba excel

-1

Chris · 技术社区 · 6 年前

我试图从五张不同的纸上复制特定范围的单元格,并将它们聚合到一张纸上,所有的单元格都粘贴在彼此的正下方。我成功地复制并粘贴了一整张工作表,但如何将其设置为特定范围,并循环浏览同一工作簿中的每一张工作表?

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

1 回复 | 直到 6 年前

IAmNerd2000 6 年前

试试这个,它应该有用:

    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