Excel-VBA二维表转换为一维表的排版方法

应用场景

利用双层循环将四列的二维表转换成一维表的排版

知识要点

1：Range.Resize(RowSize/行, ColumnSize/列) 属性调整指定区域的大小。返回 Range 对象，该对象代表调整后的区域。

2：Range.Merge 方法由指定的 Range 对象创建合并单元格

3：Range.AutoFill(Destination/填充区域, Type) 方法对指定区域中的单元格执行自动填充。

4：Range().Borders.LineStyle = 1 添加边框

Sub 格式转换()

Dim i As Integer, Cell As Range, shtnum As Integer, Arr(), j As Long

Application.ScreenUpdating = False

shtnum = ActiveSheet.Index '记录当前表地址

Worksheets.Add after:=Sheets(shtnum) '添加一个工作表在当前表之后

Sheets(shtnum 1).Name = Sheets(shtnum).Name & '格式转换' '为新表命名

Range('a1') = '入库表'

Range('A2:D2') = Array('日期', '单号', '品名', '数量')

Sheets(shtnum).Select '激活原表

'遍历需要转换的数据区域，包括纵向循环和横向循环

For i = 4 To Cells(Rows.Count, 2).End(xlUp).Row

For Each Cell In Range([C2], Cells(2, Columns.Count).End(xlToLeft))

If Cell.Offset(1 i - 3, 0) '' Then

j = j 1

ReDim Preserve Arr(1 To 4, 1 To j)

Arr(1, j) = Range('A' & i).Value

Arr(2, j) = Range('B' & i).Value

Arr(3, j) = Cell.Value

Arr(4, j) = Cell.Offset(1 i - 3, 0).Value

End If

Next Cell

Next i

Sheets(shtnum 1).[a3].Resize(j, 4) = WorksheetFunction.Transpose(Arr) '将数组写入新表中

Sheets(shtnum 1).[a2].Resize(j 1, 4).Borders.LineStyle = 1 '添加边框

Sheets(shtnum 1).[a:a].NumberFormat = 'm月d日' '将第一列格式化为端日期格式

Sheets(shtnum 1).[a2].Resize(j 1, 4).EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub