Выберите несколько диапазонов и вставьте по одному - PullRequest
Новая
       41

Выберите несколько диапазонов и вставьте по одному

0 голосов
/ 02 апреля 2020

Я действительно новичок в VBA и пытаюсь скопировать серию ie диапазонов, и мне нужно вставить один за раз (для работы со смещением).

Это то, что у меня есть: This image is what I have

И это то, что я хочу: and this image is what I want

Чтобы сделать это, я думаю, что копировать на основе диапазона только нечетные диапазоны и вставить в столбец «F» и скопировать только четные диапазоны и вставить в столбец «N».

На данный момент у меня есть этот код , Я работаю очень хорошо, но у меня есть 20 нечетных диапазонов и 20 четных диапазонов. Мне нужен простой способ соединить эти 20 повторений 

        Range("A3:G7").Copy
        Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=1).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

        Range("A15:G19").Copy
        Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

        Range("A27:G31").Copy
        Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

(здесь я просто показываю 3 повторения кода). 

    Dim ws As Worksheet

    Application.ScreenUpdating = False
    Sheets("Car").Activate
    Range("F2:AA250").Delete
    Sheets("Summary").Activate

            Range("A3:G7").Copy
            Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=1).PasteSpecial xlPasteAll
            Application.CutCopyMode = False

            Range("A15:G19").Copy
            Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll
            Application.CutCopyMode = False

            Range("A27:G31").Copy
            Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll

            Application.CutCopyMode = False
            Range("F2").Activate
    Application.ScreenUpdating = True
End Sub

Ответы [ 2 ]

0 голосов
/ 02 апреля 2020

Попробуйте этот простой метод, пожалуйста. Достаточно иметь только свой первый диапазон. В качестве альтернативы код копирует диапазон в соответствующую позицию в соответствии с номером итерации (нечетным или четным). Вы можете сделать гораздо больше итераций, только изменив номер итерации (howMany): 

Sub CopyRange_()
Dim sh As Worksheet, nextRow As Long, howMany As Long
Dim rng As Range, i As Long, No As Long
Set sh = ActiveSheet
Set rng = sh.Range("A3:L8"): nextRow = rng.Cells(1, 1).Row
No = 2: howMany = 20
rng.Copy

 For i = 1 To howMany - 1
    If i Mod 2 = 0 Then
        sh.Range("A" & nextRow).Select: sh.Paste
        sh.Range("L" & nextRow).value = No: No = No + 1
    Else
        sh.Range("N" & nextRow).Select: sh.Paste
        sh.Range("Y" & nextRow).value = No: No = No + 1
        nextRow = nextRow + rng.Rows.Count
    End If
 Next i
End Sub

Если вам потребуется больше строк, достаточно выбрать соответствующий диапазон вместо «A3: L8» , «A3: L10», например ...

0 голосов
/ 02 апреля 2020

Попробуйте это. Я не проверял его, поэтому был бы удивлен, если бы он работал в первый раз! Когда этого не произойдет, l oop остановится. For For Next l oop было бы лучше, если бы вы заранее знали, сколько вам понадобится копий. 

Sub x()

Dim r As Range, n As Long: n = 1

With Worksheets("Summary")
    Set r = .Range("A3:G7")
    Do Until IsEmpty(r.Cells(1, r.Columns.Count))
        r.Copy Worksheets("Car").Range("F" & n)
        r.Offset(r.Rows.Count + 1).Copy Worksheets("Car").Range("N" & n)
        Set r = r.Offset((r.Rows.Count + 1) * 2)
        n = n + r.Rows.Count + 1
    Loop
End With

End Sub
...