二维数据表转一维

Sub 二维数据转换为一维()
    '--------------------------------------------------------------------
    '自定义数据类型
    Dim Choose_rng As Range
    Dim Choose_sht_name As String
    Dim Choose_rng_row, Choose_rng_column As Integer
    Dim Sht As Worksheet
    Dim i, j As Long
    Dim Arr() As Variant
    
    '选择需要转换的单元格区域，获取选择单元格的表名、区域起始行、起始列
    Set Choose_rng = Application.InputBox("选择需要被转换的二维数据区域", Type:=8)
    If WorksheetFunction.CountA(Choose_rng) = 0 Then MsgBox "选择单元格区域为空": Exit Sub
    Choose_sht_name = Choose_rng.Parent.Name
    Choose_rng_row = Choose_rng.Row
    Choose_rng_column = Choose_rng.Column
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    '判断工作簿中是否存心转换的结果表，如果有则删除重新增加一个表
    For Each Sht In ThisWorkbook.Sheets
        If Sht.Name = Choose_sht_name & "转换结果" Then Sht.Delete
    Next Sht
    Worksheets.Add after:=Sheets(Choose_sht_name)
    ActiveSheet.Name = Choose_sht_name & "转换结果"
    
    
    '遍历需要转换的数据区域，包括纵向循环和横向循环，将转换结果赋值给数值并粘贴到新的工作表
    Sheets(Choose_sht_name).Select
    For i = 1 To Choose_rng.Rows.Count - 1
        For j = 1 To Choose_rng.Columns.Count - 1
                ReDim Preserve Arr(1 To 3, 1 To j)
                Arr(1, j) = Cells(i + Choose_rng_row, Choose_rng_column).Value
                Arr(2, j) = Cells(Choose_rng_row, j + Choose_rng_column).Value
                Arr(3, j) = Cells(i + Choose_rng_row, j + Choose_rng_column).Value
        Next j
        Sheets(Choose_sht_name & "转换结果").Cells((i - 1) * UBound(Arr, 2) + 1, 1).Resize(UBound(Arr, 2), UBound(Arr)) = WorksheetFunction.Transpose(Arr)
        
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "转换完成"
    Sheets(Choose_sht_name & "转换结果").Activate
    
End Sub

1：对首行、列是标题，交叉部分是内容的二维数据转换

2：自主修改部分代码做成小的应用

3：选择需要转换的单元格区域，转换成一维的数据表

源码视频演示

二维数据表转一维

目录