Цикл по наборам из трех столбцов и копирование строки (3 столбца), затем l oop на следующий набор из 3 столбцов

Question

* Я пишу макрос, который принимает забронированные выходные на одном листе и компилирует его в один столбец на другом листе. <Каждый месяц имеет 3 столбца (a, b, c). Затем следующий месяц (d, e, f) перемещается по листу до столбца (AJ). Столбец a * столбец даты b * количество принятых часов, согласованных / отклоненных c *. Следующим месяцем будет столбец * дата <столбец * количество принятых часов * согласовано / отклонено. Строка копируется только в том случае, если столбец (b) превышает 0,1 часа. Записал код в l oop в течение первого месяца, но как мне его получить, затем в l oop в течение следующих 11 месяцев (11 наборов из трех столбцов) слева направо? *</p>

Sub CopyACross()

Dim lastrow As Long, i As Long, erow As Long,

lastrow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow

Sheets("sheet1").Select


If cells(i, 2).Value > 0.1 Then

Range(cells(i, 1), cells(i, 3)).Select
Selection.Copy

Sheets("sheet4").Select

erow = ActiveSheet.cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i



End Sub

Answer 1

Вам просто нужно встроить существующий код в другой l oop, который считает столбцы. Код ниже не проверен. Пожалуйста, предупредите меня о любых опечатках, которые могут в нем содержаться.

Sub CopyAcross()
    ' 015

    Dim WsTarget As Worksheet
    Dim lastRow As Long, R As Long, eRow As Long
    Dim C As Long

    Set WsTarget = Worksheets("Sheet4")
    With WsTarget
        ' count the rows in the same sheet where you set the range
        eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    For C = 0 To 11
        With Worksheets("Sheet1")
            ' count the rows in the same sheet where you set the range
            lastRow = .Cells(.Rows.Count, (C * 3 + 1)).End(xlUp).Row

            For R = 2 To lastRow
            '    Sheets("sheet1").Select        ' don't Select anything
                If .Cells(R, (C * 3 + 2)).Value > 0.1 Then
                    eRow = eRow + 1
                    .Range(.Cells(R, (C * 3 + 1)), .Cells(R, (C * 3 + 3))).Copy _
                            Destination:=WsTarget.Cells(eRow, 1)
                End If
            Next R
        End With
    Next C
End Sub

Я позволил себе удалить все варианты, которые делает ваш код. Они не нужны и просто увеличивают объем кода, замедляя его выполнение.