макрос для переноса таблицы в столбец

Question

у меня номера расположены в таблице, как в первом ряду с 1 по 10, затем в следующем ряду с 11 по 20, затем с 21 по 30 и т. Д. Я хочу, чтобы каждая строка была перенесена в один столбец, как в любом столбце с 1 по 10, затем ниже 10, с 11 до 20, затем с 21 по 30 и так далее

Answer 1

Добавьте приведенный ниже код в новый модуль в редакторе VBA ...

Public Sub TransformDataToColumns()
    Dim rngCells As Range, objCell As Range, lngWriteRow As Long
    Dim objDestSheet As Worksheet

    Set rngCells = Selection
    Set objDestSheet = Sheets("Transformed")

    objDestSheet.Cells.Clear

    For Each objCell In rngCells
        lngWriteRow = lngWriteRow + 1
        objDestSheet.Cells(lngWriteRow, 1) = objCell.Value
    Next

    objDestSheet.Activate
End Sub

... добавить новый лист в вашу книгу под названием Преобразовано

Теперь выберите таблицу данных (как показано ниже) и запустите макрос. Все вещи остаются неизменными, это должно работать на вас.

Answer 2

Попробуйте этот код

Sub Test()
Dim r1          As Range
Dim r2          As Range

With Sheets("Sheet1")
    Set r1 = .Range("A1:D" & .Columns("A:D").Find("*", [A1], , , 1, 2).Row)
    Set r2 = .Range("K1")
    MultipleColumnsIntoOne r1, r2
End With
End Sub

Sub MultipleColumnsIntoOne(rSource As Range, rDest As Range)
Dim a           As Variant
Dim b           As Variant
Dim i           As Long
Dim j           As Long
Dim k           As Long

a = rSource.Value
ReDim b(1 To UBound(a, 1) * rSource.Columns.Count)

For j = LBound(a, 2) To UBound(a, 2)
    For i = LBound(a, 1) To UBound(a, 1)
        If Not IsEmpty(a(i, j)) Then
            k = k + 1
            b(k) = a(i, j)
        End If
    Next i
Next j

rDest.Resize(k).Value = Application.Transpose(b)
End Sub