Excel VBA - Как скопировать или переместить столбцы в одну строку?

Question

Я хочу скопировать столбцы в одну строку с помощью макроса.Значения в столбцах 1-6 должны перейти к следующей пустой строке в A. Я хочу сделать это с помощью макроса, так как у меня есть сотни и тысячи столбцов, которые нужно переместить в одну строку.Я пробовал макрос-рекордер, но не могу добиться того, чего хочудобавив ниже:

Sub Macro1()
Dim x As Integer
x = 2
Do While Cells(x, 3) <> ""
DoEvents
Sheet1.Cells(x, 1).End(xlUp).Offset(1, 0) = Sheet1.Cells(x, 3)
Sheet1.Cells(x, 1).End(xlUp).Offset(1, 0) = Sheet1.Cells(x, 4)
Sheet1.Cells(x, 1).End(xlUp).Offset(1, 0) = Sheet1.Cells(x, 5)
Sheet1.Cells(x, 1).End(xlUp).Offset(1, 0) = Sheet1.Cells(x, 6)
Sheet1.Cells(x, 1).End(xlUp).Offset(1, 0) = Sheet1.Cells(x, 7)
Sheet1.Cells(x, 1).End(xlUp).Offset(1, 0) = Sheet1.Cells(x, 8)
Sheet1.Range("C2:H2").Clear
Sheet1.UsedRange.Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
x = x + 1
Loop
End Sub

Благодарим вас за помощь.

Answer 1

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

Option Explicit

Public Sub CollectRows()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim LastRowA As Long
    Dim LastCol As Long

    Const FirstCol As Long = 3 'column C is the first column with data

    Dim LastRowC As Long
    LastRowC = ws.Cells(ws.Rows.Count, FirstCol).End(xlUp).Row 'find last row in col A

    Dim iRow As Long
    For iRow = 2 To LastRowC 'run from row 2 to last row in column C
        LastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last row in col A
        LastCol = ws.Cells(iRow, ws.Columns.Count).End(xlToLeft).Column 'find last column in current row

        'copy and transpose values
        ws.Cells(LastRowA, "A").Offset(RowOffset:=1).Resize(RowSize:=LastCol - FirstCol + 1).Value = WorksheetFunction.Transpose(ws.Cells(iRow, FirstCol).Resize(ColumnSize:=LastCol - FirstCol + 1).Value)
    Next iRow
End Sub