VBA二维表转一维表

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