Для l oop при копировании и вставке указываются c столбцы

Question

Мне нужен al oop, который будет сопоставлять и выбирать разные столбцы (не в последовательном порядке) и вставлять их на другой лист, сохраняя при этом условие. Было бы также идеально, если при вставке значений форматирование ячейки не переносится, а просто значение.

Ниже приведен код, который я сейчас использую:

Sub Test()
    Application.ScreenUpdating = False
    Sheets("DATA").Select
    lr = Range("B" & Rows.Count).End(xlUp).Row
    Range("P3").Select
    For i = 3 To lr
        If Cells(i, 2) <> "" Then Range(Cells(i, 7), Cells(i, 16), Cells(i, 26)).Copy 
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Next
    Application.ScreenUpdating = True
End Sub

Проблема заключается в объявлении столбцов, которые я хочу вставить в l oop. Мне нужно, чтобы l oop прошел через 16-й столбец, проверил пустые значения, а затем вставил индекс / совпадающее значение в строки столбцов 7, 16 и 26 (поэтому не в последовательном порядке). Любая помощь будет оценили.

Answer 1

Следующий код должен делать то, что, как я понял, вам нужно. Пожалуйста, проверьте это и подтвердите этот аспект. Он очень быстрый, работает только в памяти ...

Sub PastingNextPage()
  Dim sh As Worksheet, sh1 As Worksheet, arrIn As Variant, arrOut() As Variant
  Dim lastRowIn As Long, lastRowOut As Long, nonEmpt As Long, rngP As Range, nrEl As Long
  Dim i As Long, j As Long, P As Long

  Set sh = Sheets("DATA"): lastRowIn = sh.Range("P" & sh.Rows.count).End(xlUp).Row
  Set sh1 = Sheets("Sheet2"): lastRowOut = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row + 1

  arrIn = sh.Range("G2:Z" & lastRowIn).Value

  nrEl = lastRowIn - Application.WorksheetFunction.CountIf(sh.Range("P2:P" & lastRowIn), "") - 2
    P = 10 'column P:P number in the range starting with G:G column
    ReDim arrOut(nrEl, 3) 'redim the array to keep the collected values
    For i = 1 To lastRowIn - 1
        If arrIn(i, P) <> "" Then
            arrOut(j, 0) = arrIn(i, 1): arrOut(j, 1) = arrIn(i, P): arrOut(j, 2) = arrIn(i, 20)
            j = j + 1
        End If
    Next i

    sh1.Range(sh1.Cells(lastRowOut, "A"), sh1.Cells(lastRowOut + nrEl, "C")).Value = arrOut
End Sub

Он ничего не выбирает, вы можете запустить его, активировав любой из двух задействованных листов. Я бы порекомендовал оказаться в «Sheet2» и посмотреть результат. Если вы хотите повторить тест, его результат будет добавлен после строк результатов предыдущего тестирования ...

Если что-то неясно или не делает то, что вам нужно, не стесняйтесь спрашивать разъяснения.