VBA二维表转一维表

xyj

发布于 2020-07-28 10:37:45

2.2K0

文章被收录于专栏：VBA 学习VBA 学习

1、需求：

将1个二维表格转换为方便数据统计的一维表格：

2、举例：

工作中经常会碰到这种情况，外部收集来的资料，表格制作者为了排版好看，做成转换前的格式，这种格式看起来方便，但是做数据处理是非常不方便的，需要进行转换后进行数据处理。

3、代码实现

这个功能的逻辑还是挺简单的，2个循环就可以覆盖数据所有的范围，然后输出到1个二维数组，主要是要注意计算数组的下标：

Sub TarnsTable()
    On Error GoTo err_handle
    
    If VBA.TypeName(Selection) <> "Range" Then
        MsgBox "请选择单元格区域。"
        Exit Sub
    End If
    
    Dim rngSrc As Range, rngDes As Range
    Set rngSrc = Selection
    If rngSrc.Cells.Count < 4 Then
        MsgBox "转换至少也需要2行2列的数据！"
        Exit Sub
    End If
    
    Set rngDes = GetRng("请选择输出单元格。", rngSrc.Range("A1").Offset(rngSrc.Rows.Count + 1, 0).Address)
    If rngDes Is Nothing Then Exit Sub
    Set rngDes = rngDes.Range("A1")
    
    Dim arr(), Result() As Variant
    arr = rngSrc.Value
    Dim iRows As Long, iCols As Long
    Dim i As Long, j As Long
    
    iRows = rngSrc.Rows.Count - 1
    iCols = rngSrc.Columns.Count - 1
    ReDim Result(1 To iRows * iCols + 1, 1 To 3) As Variant
    
    Dim pRow As Long
    pRow = 1
    Result(pRow, 1) = "行标题"
    Result(pRow, 2) = "列标题"
    Result(pRow, 3) = "数据"
    For i = 2 To iRows + 1
        For j = 2 To iCols + 1
            pRow = (i - 2) * iCols + j - 1 + 1
            Result(pRow, 1) = "'" & arr(i, 1)
            Result(pRow, 2) = "'" & arr(1, j)
            Result(pRow, 3) = arr(i, j)
        Next j
    Next i
    
    rngDes.Resize(iRows * iCols + 1, 3).Value = Result
    
    Exit Sub
    
err_handle:
    MsgBox Err.Description
End Sub

Function GetRng(strPrompt As String, defaultAdd As String) As Range
    On Error Resume Next
    Set GetRng = Application.InputBox(strPrompt, Default:=defaultAdd, Type:=8)
    On Error GoTo 0
    If GetRng Is Nothing Then
        MsgBox "请选择单元格区域。"
    Else
        Set GetRng = GetRng.Range("a1")
    End If
End Function

本文参与腾讯云自媒体同步曝光计划，分享自微信公众号。

原始发表：2020-04-30，如有侵权请联系 cloudcommunity@tencent.com 删除

数据处理