L oop до незаполненного столбца

Question

Необходим для записи кода для даты вставки копии в один столбец.

, поскольку существует n номеров столбцов, и необходимо вставить их в один столбец.

код, который я пробовал но не работает хорошо

    Sub Macro4()
'
' Macro4 Macro
'

'
    Range("C3").Select
    Selection.Copy
    Range("B4:B12").Select
    ActiveSheet.Paste
    Range("E3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("D4:D12").Select
    ActiveSheet.Paste
    Range("G3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("F4:F8").Select
    ActiveSheet.Paste
    Range("I3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("H4:H10").Select
    ActiveSheet.Paste
    Range("B4:C12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    Range("D2").Select
    ActiveSheet.Paste
    Sheets("Sheet4").Select
    Range("D4:E12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    Range("D11").Select
    ActiveSheet.Paste
    Sheets("Sheet4").Select
    Range("F4:G8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    Range("D20").Select
    ActiveSheet.Paste
    Sheets("Sheet4").Select
    Range("H4:I10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    Range("D25").Select
    ActiveSheet.Paste
End Sub

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

Answer 1

Измените диапазоны и попробуйте:

Option Explicit

Sub test()

    Dim LastRowCol As Long, LastRowOut As Long, i As Long, StartColumn As Long, Endcolumn As Long

    StartColumn = 2
    Endcolumn = 6

    With ThisWorkbook.Worksheets("Sheet1")

        For i = StartColumn To Endcolumn Step 2

            LastRowCol = .Cells(.Rows.Count, i).End(xlUp).Row

            LastRowOut = .Cells(.Rows.Count, "J").End(xlUp).Row

            .Range(.Cells(4, i), .Cells(LastRowCol, i + 1)).Copy .Range("J" & LastRowOut + 1)

        Next i

    End With

End Sub

Результат:

Answer 2

Добро пожаловать в StackOverflow. И добро пожаловать в VBA. Пожалуйста, изучите пример кода ниже. это будет делать то, что вы описали.

Option Explicit                         ' always use this statement

Sub LoopColumns()

    ' always identify and declare your worksheets
    Dim WsS As Worksheet                ' Source sheet
    Dim WsD As Worksheet                ' Destination sheet
    Dim CopyRange As Range
    Dim C As Long                       ' column number
    Dim Rld As Long                     ' last row in WsD

    Set WsS = ActiveSheet               ' better identify the sheet by name
    Set WsS = Worksheets("Sheet1")      ' this is the sheet I used
    Set WsD = Worksheets("Sheet5")      ' better give the sheet a descriptive name

    For C = 1 To 6 Step 2               ' select columns 1, 3 and 5 in turn
        ' specify the range starting in row 4 of the looped column
        '   and end at the end of that column, offset by 1
        Set CopyRange = WsS.Range(WsS.Cells(4, C), _
                                  WsS.Cells(WsS.Rows.Count, C).End(xlUp).Offset(0, 1))

        ' determine the row below the last used row in WsD
        Rld = WsD.Cells(WsD.Rows.Count, 1).End(xlUp).Row + 1
        If Rld < 3 Then Rld = 3         ' start from row 3 3
        ' paste to column A below the last used row
        CopyRange.Copy Destination:=WsD.Cells(Rld, "A")
    Next C
End Sub