Копирование нескольких диапазонов и листов

Я пытаюсь скопировать несколько диапазонов из книги в один лист в другой. Я пытался использовать MyMultipleRange, но продолжаю получать сообщение «Метод« Объединение »объекта_« Глобальный »не удалось.

Function WorkbookName() As String
    WorkbookName = ThisWorkbook.Name
End Function

Sub dataimport()
    Dim i As Integer
    Dim Data

    Workbooks(WorkbookName).Activate
    Sheets("Input").Select
    Datapath = Cells(15, 4)
    Data = Cells(15, 3)

    Application.Workbooks.Open (Datapath)

    Dim r1, r2, myMultipleRange As Range
    Set r1 = Sheets("Sheet1").Range("A1:Ak518")
    Set r2 = Sheets("Sheet2").Range("B2:J10")
    Set myMultipleRange = Union(r1, r2)

    Workbooks(WorkbookName).Activate
    Sheets("Sheet5").Select
    Range("A1:Ak600").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


     Workbooks(Data).Close savechanges:=False

End Sub

excel range vba copying
person Hin899    schedule 10.01.2018    source источник
comment
Вы не можете использовать Union на разных листах.   -  person SJR    schedule 10.01.2018
comment
Каков наилучший способ сделать это тогда? Мне нужно скопировать диапазоны с обоих листов 1 и 2.   -  person Hin899    schedule 10.01.2018
comment
Вы пробовали искать? Например. stackoverflow.com/questions/25801941/   -  person SJR    schedule 10.01.2018

Ответы (1)


arrow_upward
0
arrow_downward

Я думаю, это сделает то, что вы хотите.

Set CopyRng = sh.Range("A1:G1")

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A1:G1")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
person ASH    schedule 11.01.2018