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