Скопируйте значение из той же строки в другом столбце, который соответствует диапазону непустых ячеек

Я пытаюсь получить код, который мог бы сделать две операции в одной и той же подпрограмме, если это возможно. В настоящее время у меня есть подпрограмма, которая копирует диапазон ячеек (от 1 до 19) из смежных столбцов из непустых ячеек и вставляет их в другой лист (см. Ниже код). Теперь я хочу добавить операцию, которая также может копировать значение из другого столбца (A:A), но из тех же строк предыдущего выбранного диапазона. Проблема в том, что в этом столбце А нет пустых ячеек.

    Option Explicit

Sub summarize1()

Dim sIn As Worksheet, sOut As Worksheet, rIn As Range, rOut As Range
Dim inputdata() As Variant
Dim tmpArr(1 To 19) As Variant
Dim i As Long, outcount As Long

Set sIn = Sheets("Plants Data")
Set sOut = Sheets("Nutrients")
Set rIn = sIn.UsedRange
Set rOut = sOut.Range("B1:T1")

'Loads input data into an array for fast processing.
inputdata = rIn.Value
outcount = 0

'Reads data from inputdata Array and prints selected values from specified columns on Output sheet row by row.
For i = 1 To UBound(inputdata, 1)
    If inputdata(i, 138) <> "" Then
        outcount = outcount + 1
        tmpArr(1) = inputdata(i, 138)
        tmpArr(2) = inputdata(i, 139)
        tmpArr(3) = inputdata(i, 140)
        tmpArr(4) = inputdata(i, 141)
        tmpArr(5) = inputdata(i, 142)
        tmpArr(6) = inputdata(i, 143)
        tmpArr(7) = inputdata(i, 144)
        tmpArr(8) = inputdata(i, 145)
        tmpArr(9) = inputdata(i, 146)
        tmpArr(10) = inputdata(i, 147)
        tmpArr(11) = inputdata(i, 148)
        tmpArr(12) = inputdata(i, 149)
        tmpArr(13) = inputdata(i, 150)
        tmpArr(14) = inputdata(i, 151)
        tmpArr(15) = inputdata(i, 152)
        tmpArr(16) = inputdata(i, 153)
        tmpArr(17) = inputdata(i, 154)
        tmpArr(18) = inputdata(i, 155)
        tmpArr(19) = inputdata(i, 156)
        rOut.Offset(outcount - 1, 0).Value = tmpArr
      Erase tmpArr
    End If
    Next i
Erase inputdata

End Sub

Есть ли кто-нибудь, кто мог бы помочь с этим?

Спасибо

0 ответов

Другие вопросы по тегам