Как я могу скопировать значения прошлого + вставки из разных ячеек из разных листов в одну?

Question

Мне нужна ваша помощь.

У меня есть код, который может копировать значения из разных ячеек из листа в другой. Я хотел взять этот код и применить его для копирования значений из других файлов. Однако я не хочу вставлять значения в один и тот же столбец ... и вот что произошло. Могу ли я автоматически изменить диапазон в каждом l oop?

Sub Teste()

Dim NrCop As Integer 'this is the number of files I want

Set b = Workbooks.Open(Application.GetOpenFilename) 'the file that I want to past my values on
NrCop = InputBox("Quantos promotores são?")
Set a = Workbooks.Open(Application.GetOpenFilename) 'the files I want to copy the values from

For x = 1 To NrCop

    a.Activate
    Range("D4").Select 'this range is static
    Selection.Copy
    b.Activate
    Range("B3").Select ' for the next loop I want this range to change for C3
    Selection.PasteSpecial Paste:=xlPasteValues

    a.Activate
    Range("D5").Select
    Selection.Copy
    b.Activate
    Range("B4").Select
    Selection.PasteSpecial Paste:=xlPasteValues
     a.Activate
    Range("D11").Select
    Selection.Copy
    b.Activate
    Range("B5").Select
    Selection.PasteSpecial Paste:=xlPasteValues
     a.Activate
    Range("D37").Select
    Selection.Copy
    b.Activate
    Range("B6").Select
    Selection.PasteSpecial Paste:=xlPasteValues
     a.Activate
    Range("D48").Select
    Selection.Copy
    b.Activate
    Range("B7").Select
    Selection.PasteSpecial Paste:=xlPasteValues
     a.Activate
    Range("D74").Select
    Selection.Copy
    b.Activate
    Range("B8").Select
    Selection.PasteSpecial Paste:=xlPasteValues
     a.Activate
    Range("D100").Select
    Selection.Copy
    b.Activate
    Range("B9").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D126").Select
    Selection.Copy
    b.Activate
    Range("B12").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D152").Select
    Selection.Copy
    b.Activate
    Range("B13").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D178").Select
    Selection.Copy
    b.Activate
    Range("B14").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D204").Select
    Selection.Copy
    b.Activate
    Range("B15").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D205").Select
    Selection.Copy
    b.Activate
    Range("B16").Select
    Selection.PasteSpecial Paste:=xlPasteValues
     a.Activate
    Range("D209").Select
    Selection.Copy
    b.Activate
    Range("B17").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D212").Select
    Selection.Copy
    b.Activate
    Range("B18").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    a.Activate
    Range("D216").Select
    Selection.Copy
    b.Activate
    Range("B19").Select
    Selection.PasteSpecial Paste:=xlPasteValues

Next x

End Sub

Можете ли вы помочь мне?

Answer 1

Использование массивов и переменных упрощает код и ускоряет выполнение.

Sub test()
    Dim a As Workbook, b As Workbook
    Dim Ws As Worksheet, toWs As Worksheet
    Dim x As Integer, NrCop As Integer, n As Integer
    Dim i As Integer
    Dim vArray As Variant
    Dim vR() As Variant 'dynamic array

    Set b = Workbooks.Open(Application.GetOpenFilename) 'the file that I want to past my values on
    Set toWs = b.Sheets(1)

    NrCop = InputBox("Quantos promotores sao?")
    Set a = Workbooks.Open(Application.GetOpenFilename) 'the files I want to copy the values from
    Set Ws = a.Sheets(1)

    vArray = Array(4, 5, 11, 37, 48, 74, 100, 126, 152, 178, 204, 205, 209, 212, 216)
    n = UBound(vArray)
    ReDim vR(n)
    For i = 0 To n
        vR(i) = Ws.Range("d" & vArray(i))
    Next i

    For x = 1 To NrCop
        toWs.Range("b3").Offset(0, x - 1).Resize(n + 1) = WorksheetFunction.Transpose(vR)
    Next x

End Sub