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

Question

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

требуемый результат рабочий лист ss это лист ss я хочу транспонировать и вставлять данные в столбец A

B01MU6O7H7                              
B07XB9NN9B  B07261QWHY  B071W4GMN3  B07X8BPD82  B07X8BNJZQ  B07X8BNBJH          
B071JLW811  B071WK2YKV  B071WK2QHN  B072JTCJF8  B071G11SR7  B072QCCV2Q  B0743JHJBH      
B078GVQFB5  B078GQ9V6W  B078GTFHMY  B078GR4H15  B079KFH765  B078GTXD9N  B078GPVH73      
B078G6515S                              
B07T891H6J  B07T9DFRSM  B07T893RJM  B07TFHJ1XR  B07T9DGB2V  B07TFHJ6ZX  B07TBFC852      
B01N2WJ0OR  B01MQYNB3M  B06Y3Z65C5  B01MQZU45F                  
B076YFYD19  B076YF2ZNY  B074Z9ZY1S  B076XZ9WZV  B079KSDHSQ  B079KQJHZD  B074ZK64V3      
B07XJYL5Y2  B07XL3Y773                          
B07FCQTZ5X  B06XZ7Z93Z                          
B07MN7YHLM  B07M9HGJWP  B07MK98FJ5  B07M9HGN5D  B01NCVGDIC  B01N4NBSV9  B07MN8YKFQ  B074MZ93JP  B01N7RH9ZB
B07TKXWLFZ  B071CMQ6N2  B07VG1L2M5                      
B01B0SR1IY                              
B07GZFZQ6H  B07GZHSBRT  B07GZHG64J  B07GZDQ7QW                  
B07WLX685Q  B07WF3MQPB  B07WD3CHDW  B07W9KXP9Q  B07WG787XB  B07WD3BCDR          
B07J2K4WCV  B07J2MGH5W  B07J2L9MZS  B07J2LF71R                  
B07F9VP9QM  B07F9ZLCZW  B07FB1XZGL                      

---

Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "KutoolsforExcel"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Answer 1

Если у вас есть Excel 2010+, вы можете использовать Power Query (он же Get & Transform в 2016 +).

• Выберите ячейку в таблице
• В 2016 году, Вы перейдете на вкладку Data; затем выберите Get & Transfrom из Table/Range
• В открывшемся редакторе PQ:
  • Выбрать все столбцы
  • На вкладке Transform выберите Unpivot Columns
• Удалить столбец Attribute
• Закрыть и загрузить

M-код: *, сгенерированный PQ * *

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}, {"Column4", type text}, {"Column5", type text}, {"Column6", type text}, {"Column7", type text}, {"Column8", type text}, {"Column9", type text}}),
    #"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Changed Type", {}, "Attribute", "Value"),
    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Columns",{"Attribute"})
in
    #"Removed Columns"

Результаты

Answer 2

Предполагая:

1. диапазон источника: A1 до I17 в Sheet1
2. пункт назначения Лист2
3. данные являются постоянными

try:

Sub dural()
    Dim rng As Range, cell As Range, WhereTo As Range
    Dim i As Long, rc As Long, arr

    Set rng = Range("A1:I17").SpecialCells(xlCellTypeConstants)
    rc = rng.Count

    Set WhereTo = Sheets("Sheet2").Range("A1:A" & rc)
    ReDim arr(1 To rc, 1 To 1)

    i = 1
    For Each cell In rng
        arr(i, 1) = cell.Value
        i = i + 1
    Next cell

    WhereTo = arr

End Sub

Примечание:

Использование SpecialCells позволяет избежать тара.

Answer 3

Попробуйте что-то вроде этого:

L oop ячеек в вашем диапазоне, если не пусто, присвойте значение массиву, а затем запишите массив из набора назначения.

Sub TransposeMultiColumnDataToOneColumn()
Dim myArray As Variant
Dim SourceRange As Range, DestinationRange  As Range

Set SourceRange = Application.InputBox("Source Ranges:", xTitleId, Type:=8)
Set DestinationRange = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)

Dim ArrayCounter As Long
ReDim myArray(1 To SourceRange.Count)
Dim CellToCheck As Range

ArrayCounter = 0

For Each CellToCheck In SourceRange
    If Not CellToCheck.Value = Empty Then
        ArrayCounter = ArrayCounter + 1
        myArray(ArrayCounter) = CellToCheck.Value
    Else '
        'Cell is empty, do nothing
    End If
Next CellToCheck

ReDim Preserve myArray(1 To ArrayCounter)

Set DestinationRange = DestinationRange.Resize(UBound(myArray), 1)
DestinationRange.Value = Application.Transpose(myArray)

End Sub

Answer 4

Попробуй,

Sub test()
    Dim vDB As Variant
    Dim vR() As Variant
    Dim i As Long, n As Long, r As Long
    Dim j As Integer, c As Integer
    Dim Ws As Worksheet

    vDB = Range("b3").CurrentRegion
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)
    For i = 1 To r
        For j = 1 To c
            If vDB(i, j) <> "" Then '<~~ edited mistyped vDB(i, 1) to vDB(i, j)
                n = n + 1
                ReDim Preserve vR(1 To n)
                vR(n) = vDB(i, j)
            End If
        Next j
    Next i
    Set Ws = Sheets(1)
    With Ws
        .Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 5

Если вы используете функцию FilterXML() в вер. 2013+ вы можете попробовать следующий подход, выполнив следующие действия:

• объявление источника и целевого диапазона (см. Разделы [0] и [1])
• назначить все данные в используемом диапазоне для 1-мерного массива (см. [2])
• удалить пустые ячейки с помощью FilterXML (см. [3])
• записать массив в целевой столбец (см. [4])

Sub ListAllTo1Column()
    '[0] set target range to memory and clear existing data
    Dim tgt As Range: Set tgt = Sheet2.Range("A:A")
    tgt = vbNullString    ' clear target column (before declaring source range)

    '[1] set source range to memory
    Dim src As Range: Set src = Sheet1.UsedRange

    '[2] get all data
    ReDim arr(1 To src.Cells.Count)
    Dim cell As Variant, i As Long
    For Each cell In src
        i = i + 1: arr(i) = cell
    Next cell

    '[3] remove empty cells
    arr = WorksheetFunction.FilterXML("<t><s>" & Join(arr, "</s><s>") & "</s></t>", "//s[not(.='')]")

    '[4] write results to target
    'Debug.Print Join(Application.Transpose(arr), ", ")
    tgt.Resize(UBound(arr), 1).Offset(1) = arr
End Sub

Некоторые подсказки `Filter XML function:

WorksheetFunction.FilterXML() получает два аргумента:

1. хорошо сформированная строка из xml" узлов "с начальные и закрывающие теги, в некотором роде сопоставимые с HTML;
2. a XPath query строка, определяющая, какие узлы (то есть узел значения в VBA) вы хотите извлечь.

Итак arr = WorksheetFunction.FilterXML("<t><s>" & Join(arr, "</s><s>") & "</s></t>", "//s[not(.='')]")

• преобразует элементы массива с помощью функции Join(), чтобы окружить их тегами <s>...</s> в своем первом аргументе и
• определяет во втором аргументе строку поиска XMLPath для любых s узлов (на любом уровне иерархии между прочим из-за //s), добавляя условие в скобках, чтобы не искать пустые значения через [not(.='')], где указывается аббревиатура точки . до значения предыдущего узла перед скобкой.

Альтернативная оценка Excel 2019 TEXTJOIN() - Изменить / 2020-04-28

Если вы выберете версию 2019, вы можете использовать следующий фрагмент кода

Dim tmp: tmp = Split(Evaluate("=TEXTJOIN("","",True,Sheet1!" & Replace(Sheet1.UsedRange.Address, "$", "") & ")"), ",")
' Debug.Print Join(tmp, "|")

tgt.Resize(UBound(tmp), 1).Offset(1) = Application.Transpose(tmp)