如何在Excel中将表格转换为三列

Question

如何在Excel中将表格转换为三列

4

我正在使用Excel处理一个抽取文件。它基本上是多个列，每个列有多行数据。

 A   | B   | C    | D   | E   | F    |
 1   | 2   | 3    | 1   | 2   | 3    |
 4   | 5   | 5    | 4   | 5   | 5    |

我想将它展开成三列，就像这样:

 A   | B   | C    |
 1   | 2   | 3    |
 4   | 5   | 5    |
 D   | E   | F    |
 1   | 2   | 3    |
 4   | 5   | 5    |

我想使用VBA进行操作，但是我对这种语言非常新手，以下是我目前所做的事情：

Sub test()
    Dim Key, Dic As Object, cl As Range, Data As Range, i&, n&
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    i = Cells(Rows.Count, "A").End(xlUp).Row
    n = 1
    Set Data = Range("B2:B" & i & "," & "D2:D" & i & "," & "F2:F" & i & "," & "H2:H" & i)
    Dic.Add "|ID", "Date|Thing"
    For Each cl In Data
        If Cells(cl.Row, "A") <> "" Then
            Dic.Add n & "|" & Cells(cl.Row, "A"), cl.Text & "|" & cl.Offset(, 1).Text
            n = n + 1
        End If
    Next cl
    n = 1
    For Each Key In Dic
        Cells(n, "K") = Split(Key, "|")(1)
        Cells(n, "L") = Split(Dic(Key), "|")(0)
        Cells(n, "M") = Split(Dic(Key), "|")(1)
        n = n + 1
    Next Key
End Sub

它给我这个结果：

 A   | A   | A    |
 B   | B   | B    |
 C   | C   | C    |
 1   | 1   | 1    |
 2   | 2   | 2    |
 3   | 3   | 3    |
 4   | 4   | 4    |
 5   | 5   | 5    |
 6   | 6   | 6    |
 D   | D   | D    |
 E   | E   | E    |
 F   | F   | F    |
 1   | 1   | 1    |
 2   | 2   | 2    |
 3   | 3   | 3    |
 4   | 4   | 4    |
 5   | 5   | 5    |
 6   | 6   | 6    |

能帮我一下吗？

- Alban Perrier

5个回答

3

这段代码会将

变成

你只需要定义你想要的列数: Const AmountOfColumns As Long = 3

Option Explicit

Public Sub LimitColumns()
    Const AmountOfColumns As Long = 3  ' define how many columns you want in the end
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    Dim LastRow As Long  ' amount of initial rows
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim LastCol As Long  ' amount of initial columns
    LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    Dim AmountOfSteps As Long  ' amount of blocks we need to copy
    AmountOfSteps = LastCol \ AmountOfColumns
    
    Dim LastStep As Long  ' if the last block is smaller
    LastStep = LastCol Mod AmountOfColumns
    
    ' move all blocks
    Dim s As Long
    For s = AmountOfColumns + 1 To AmountOfColumns * AmountOfSteps Step AmountOfColumns
        ws.Cells(1, s).Resize(LastRow, AmountOfColumns).Cut ws.Cells(((s - 1) / AmountOfColumns) * LastRow + 1, 1)
    Next s
    
    ' move last block  (if it has less columns than the others)
    If LastStep > 0 Then
        ws.Cells(1, AmountOfSteps * AmountOfColumns + 1).Resize(LastRow, LastStep).Cut ws.Cells(AmountOfSteps * LastRow + 1, 1)
    End If
End Sub

这里使用了剪切和粘贴，如果你只想移动值（不需要格式），可以改为以下内容：

    ' move all blocks
    Dim s As Long
    For s = AmountOfColumns + 1 To AmountOfColumns * AmountOfSteps Step AmountOfColumns
        ws.Cells(((s - 1) / AmountOfColumns) * LastRow + 1, 1).Resize(LastRow, AmountOfColumns).Value2 = ws.Cells(1, s).Resize(LastRow, AmountOfColumns).Value2
    Next s
    
    ' move last block  (if it has less columns than the others)
    If LastStep > 0 Then
        ws.Cells(AmountOfSteps * LastRow + 1, 1).Resize(LastRow, LastStep).Value2 = ws.Cells(1, AmountOfSteps * AmountOfColumns + 1).Resize(LastRow, LastStep).Value2
    End If
            
    ' clear old values
    ws.Cells(1, AmountOfColumns + 1).Resize(LastRow, LastCol - AmountOfColumns).ClearContents

这可能会更快。

- Pᴇʜ

谢谢，那个完美地运行了！我会尝试从中学习。 - Alban Perrier

@Pᴇʜ 先生，刚刚尝试了，完美运行！ - Mayukh Bhattacharya

2

获取堆积柱形图

如果您不是OP，请打开新的工作簿并确保您拥有Sheet1和Sheet2选项卡以测试。将代码复制到标准模块（例如Module1）中。在Sheet1单元格A1开始添加一些连续数据（无空行或列），然后运行第一个过程。在Sheet2中查看结果。调整常量ColumnsCount和Gap，以查看它们如何改变结果。

Option Explicit

Sub GetStackedColumnsTEST()
         
     Const sName As String = "Sheet1"
     Const sFirstCellAddress As String = "A1"
     Const ColumnsCount As Long = 3
     Const Gap As Long = 0
     
     Const dName As String = "Sheet2"
     Const dFirstCellAddress As String = "A1"
         
     Dim wb As Workbook: Set wb = ThisWorkbook
     
     Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
     Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
     
     Dim Data As Variant: Data = GetStackedColumns(srg, ColumnsCount, Gap)
     Dim rc As Long: rc = UBound(Data, 1)
     
     Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
     With dws.Range(dFirstCellAddress).Resize(, ColumnsCount)
         .Resize(rc) = Data
         .Resize(dws.Rows.Count - .Row - rc + 1).Offset(rc).ClearContents
     End With
    
End Sub

Function GetStackedColumns( _
    ByVal SourceRange As Range, _
    ByVal ColumnsCount As Long, _
    Optional ByVal Gap As Long = 0) _
As Variant
    Const ProcName As String = "GetStackedColumns"
    On Error GoTo ClearError
    
    Dim rCount As Long: rCount = SourceRange.Rows.Count
    Dim cCount As Long: cCount = SourceRange.Columns.Count
    
    Dim sData As Variant: sData = SourceRange.Value
    
    Dim StacksCount As Long: StacksCount = Int(cCount / ColumnsCount)
    Dim ColumnCrumbs As Long: ColumnCrumbs = cCount Mod ColumnsCount
    If ColumnCrumbs > 0 Then StacksCount = StacksCount + 1
    
    Dim drCount As Long
    drCount = StacksCount * rCount + (Gap * (StacksCount - 1))
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
    
    Dim st As Long, sr As Long, sc As Long, dr As Long, dc As Long
    
    For st = 1 To StacksCount - 1
        sc = (st - 1) * ColumnsCount
        For sr = 1 To rCount
            dr = dr + 1
            For dc = 1 To ColumnsCount
                dData(dr, dc) = sData(sr, sc + dc)
            Next dc
        Next sr
        dr = dr + Gap
    Next st
    
    If ColumnCrumbs = 0 Then ColumnCrumbs = ColumnsCount
    sc = (st - 1) * ColumnsCount
    For sr = 1 To rCount
        dr = dr + 1
        For dc = 1 To ColumnCrumbs
            dData(dr, dc) = sData(sr, sc + dc)
        Next dc
    Next sr
    
    GetStackedColumns = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

- VBasic2008

1

先生，眨眼之间，如此之快。谢谢，我从你们身上学到了很多！ - Mayukh Bhattacharya

1

这也可以通过Power Query来实现，Power Query可用于Windows Excel 2010+和Excel 365（Windows或Mac）。

使用Power Query：

- 在您的数据表中选择一些单元格。 - Data => 获取&转换 => 来自表/范围 或 从工作表内部获取。 - 当PQ编辑器打开时：主页 => 高级编辑器。 - 注意第2行中的表格名称。 - 将下面的M代码粘贴到所见内容的位置。 - 将第2行中的表格名称更改回最初生成的名称。 - 阅读注释并探索应用步骤以了解算法。

let
    Source = Excel.CurrentWorkbook(){[Name="Table31"]}[Content],

//demote headers since they will be part of the column content
   #"Demoted Headers" = Table.DemoteHeaders(Source),
    colNames = Table.ColumnNames(#"Demoted Headers"),

//split the list of column names into groups of three
    triplets = List.Split(colNames,3),

//split into three column tables
    cols3Tables = List.Accumulate(triplets,{},(state,current)=>
        state & {Table.SelectColumns(#"Demoted Headers",current)}),

//Change column headers to be the same for each table
    renameHeaders = List.Transform(cols3Tables, each Table.RenameColumns(_,    
        List.Zip({Table.ColumnNames(_),Table.ColumnNames(cols3Tables{0})}))),

//convert list to table
// then expand it
    #"Converted to Table" = Table.FromList(renameHeaders, Splitter.SplitByNothing(), null, null, ExtraValues.Error),
    #"Expanded Column1" = Table.ExpandTableColumn(#"Converted to Table", "Column1", 
        {"Column1", "Column2", "Column3"}, {"Column1", "Column2", "Column3"})

in
    #"Expanded Column1"

- Ron Rosenfeld

1

如果我理解正确，您想将以下内容更改为：

变成以下内容：

您可以使用以下代码来实现。请注意，我上次积极编程是几年前，因此这不是最优化的。

Sub adjustList()
    Dim columWhereToSplit As Integer
    Dim lastColumn As Integer
    Dim columnsFormatted As Integer
    columWhereToSplit = 7
    lastColumn = 12
    columnsFormatted = 0
    
    NumRows = Cells(Rows.Count, columWhereToSplit).End(xlUp).Row
    
    For counter = columWhereToSplit To lastColumn
        Cells(1, counter).Select
        For counter_2 = 1 To NumRows
            Cells(counter_2, counter).Select
            Cells(NumRows + counter_2, 1 + columnsFormatted) = ActiveCell
            ActiveCell = ""
        Next
        columnsFormatted = columnsFormatted + 1
    Next
End Sub

- Nikita Meier

1

你可能会从阅读如何避免在Excel VBA中使用Select中受益。请注意，在VBA中，行和列的计数是以Long而不是Integer为单位的。 - Pᴇʜ

谢谢，我会查看一下。 - Nikita Meier

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- ashleedawg · Accepted Answer

除非我漏掉了什么，否则您正在过度复杂化。

如果您有这个：

...那么使用这个：

Range("D1:F3").Cut Range("A4")

...得到这个：

这里是关于Range.Cut方法的更多信息。

适用于学习如何自动化基本任务，参见"记录宏生成代码"。在"Office中开始使用VBA"也有很好的信息。