在Excel中将多行转换为单列

Question

我拥有各种出版商的大量书籍数据，有4行记录，有5记录记录，有3记录记录，每个记录都以一个空单元格结尾，如下所示：

1111
2222
3333
4444
emptyCell
5555
6666
7777
8888
9999
emptyCell
1234
5678
9999

哪些公式/宏代码可用于获取以下内容的输出：

1111 2222 3333 4444
5555 6666 7777 8888 9999
1234 5678 9999

Answer 1

一种可能的解决方案：

Sub test()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim rng As Range: Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp).Offset(1))
    Dim cl As Range, key As Variant, strToAdd$: strToAdd = ""
    For Each cl In rng
        If cl.Value2 <> "" Then
            strToAdd = strToAdd & " " & cl.Value2
        Else
            dic.Add strToAdd, Nothing
            strToAdd = ""
        End If
    Next cl
    Dim sh As Worksheet, i&: i = 1
    Set sh = Worksheets.Add: sh.Name = "Result"
    For Each x In dic
        sh.Cells(i, "A").Value2 = x
        i = i + 1
    Next x
End Sub

基于提供的数据集的测试：

更新：如果行中的结果应该具有自己的单元格

Sub test2()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim rng As Range: Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp).Offset(1))
    Dim cl As Range, key As Variant, strToAdd$: strToAdd = ""
    For Each cl In rng
        If cl.Value2 <> "" Then
            strToAdd = strToAdd & "|" & cl.Value2
        Else
            dic.Add strToAdd, Nothing
            strToAdd = ""
        End If
    Next cl

    Dim sh As Worksheet: Set sh = Worksheets.Add:
    Dim x, y$, z&, i&: i = 1
    sh.Name = "Result " & Replace(Now, ":", "-")

    For Each x In dic
        y = Mid(x, 2, Len(x))
        For z = 0 To UBound(Split(y, "|"))
            sh.Cells(i, z + 1).Value2 = Split(y, "|")(z)
        Next z
        i = i + 1
    Next x
End Sub

基于提供的数据集的测试：

Answer 2

我解释了这个问题，因为将单元格值复制到该行时应具有自己的单元格。

您需要定义应开始并粘贴到（columnComparePaste = 2 'where 2 = Column B）中的工作簿名称，工作表名称以及列。

那么这是一个可能的解决方案。

VBA代码

Sub CompareCopyFilter()

Dim CopyFromWorkbook As Workbook
Set CopyFromWorkbook = Workbooks("Book2.xlsm") 'Name the Workbook that should be copied from
Dim CopyToWorkbook As Workbook
Set CopyToWorkbook = Workbooks("Book2.xlsm") 'Name the Workbook that should be copied to
Dim CopyFromSheet As Worksheet
Set CopyFromSheet = CopyFromWorkbook.Worksheets("Sheet1") 'Name the Worksheet that should be copied from
Dim CopyToSheet As Worksheet
Set CopyToSheet = CopyToWorkbook.Worksheets("Sheet1") 'Name the Worksheet that should be copied to
Dim lrow As Long
Dim lrowCompare As Long
Dim lrowPasteCopyTo As Long
Dim Val As String
Dim ValCompare As String
Dim i As Long
Dim j As Long
Dim Test As String
Dim Test2 As String
Dim columnComparePaste As Long
Dim columnCompare As Long

columnComparePaste = 2 'Which column number the data should be past into (Column B = 2)


lrow = CopyFromSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Find last row in sheet that should be copied from
lrowCompare = CopyToSheet.Cells(Rows.Count, "B").End(xlUp).Row 'Find last row in sheet that should be copied from
columnCompare = columnComparePaste 'Dummy variable to reset column number

For i = 1 To lrow 'Find last row in the range you want to copy from
Val = CopyFromSheet.Cells(i, "A").Value 'Get the value from the cell you want to copy from
    If Val <> "" Then 'If cell is not empty then
            CopyFromSheet.Activate 'Activate worksheet to copy from
            CopyFromSheet.Range(Cells(i, "A"), Cells(i, "A")).Copy 'Copy cell from column A, row i
            CopyToSheet.Activate 'Activate worksheet to paste into
            CopyToSheet.Range(Cells(lrowCompare, columnCompare), Cells(lrowCompare, columnCompare)).PasteSpecial xlPasteValues 'Paste cell from into Column set earlier, add 1 column for each loop
            columnCompare = columnCompare + 1 'When value is pasted to column, add 1 column for next loop to paste into
    Else
    lrowCompare = lrowCompare + 1 'For each empty cell add one row below previous to paste into
    columnCompare = columnComparePaste 'Reset the column value where paste should start
    End If
Next i
Application.CutCopyMode = False 'Deselect any copy selection
End Sub

Excel中的结果

Answer 3

使用以下VBA代码将数据转置为空格。这不会删除原始代码。

Sub Transpose()
Dim rng As Range
Dim i As Long
Dim j As Long
Set rng = Cells(Rows.Count, 1).End(xlUp)
j = 1
For i = 1 To rng.Row Step 5
Cells(j, "B").Resize(1, 5).Value = _
Application.Transpose(Cells(i, "A").Resize(6, 1))
j = j + 1
Next
End Sub

source

Answer 4

Public Sub DataTranspose()
    Dim NoRows As Long, CurrentRow As Long, OffsetColumn As Long
    Dim ResetCurrentRow As Long, ResetOffsetColumn As Long
    Dim i As Long

    ' Replace with your destination. This will start writing back to Row 1 Column B
    ResetCurrentRow = 1
    ResetOffsetColumn = 2

    ' Replace with reference to your sheet
    With ActiveSheet
        NoRows = .Cells(.Rows.Count, 1).End(xlUp).Row

        CurrentRow = ResetCurrentRow
        OffsetColumn = ResetOffsetColumn

        For i = 1 To NoRows
            If .Cells(i, 1) <> vbNullString Then
                .Cells(CurrentRow, OffsetColumn).Value2 = .Cells(i, 1).Value2
                OffsetColumn = OffsetColumn + 1
            Else
                CurrentRow = CurrentRow + 1
                OffsetColumn = ResetOffsetColumn
            End If
        Next i
    End With
End Sub