EXCEL使用VBA多维表转一维表（通用）

从小白小菜开始

已于 2023-09-06 16:03:52 修改

阅读量1.8k

点赞数 2

分类专栏： vba 文章标签： excel 数据库

于 2023-02-15 09:39:05 首次发布

本文链接：https://blog.csdn.net/weixin_31707323/article/details/129037266

版权

vba 专栏收录该内容

4 篇文章

订阅专栏

该文章介绍了一个VBA宏，用于将一维表格转换为多维表格。用户需输入目标表名、行标题行数和列标题列数，宏会检查新表名是否存在并创建新表。宏遍历原表内容，将数据填充到新表中，以实现表格转换。文章还提到宏存在的问题，即依赖当前工作簿，建议改进为插件形式。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

多维表样式约定

在这里插入图片描述
一、表格从A1为起点。
二、如图为例转换的目标表格行标题为： 年级、班级、星期、午别、节次、科目。
三、此表为当前活动表，需要输入参数为：目标表名，行标题行数，列标题列数(均使用InputBox()函数接收。
四、具体宏实现。（注释写的很详细了）

Sub 转换一维表格()
'
' 转换一维表格 李学保
' 时间: 2023/02/14

'当前活动表名
Dim currentSheetName As String
currentSheetName = ActiveSheet.Name

'转换生成表名
Dim resultSheetName
resultSheetName = InputBox("请填写转换后表名： ", "换后表名")


'遍历工作薄现有表表名，判断是否重名
Dim sht As Worksheet

For Each sht In Sheets

    If sht.Name = resultSheetName Then
    
      MsgBox ("与已有表重名！")
      
      Return
    
    End If
    
Next
'在最后增加新表
Sheets.Add after:=Sheets(Sheets.Count)
        
Sheets(Sheets.Count).Name = resultSheetName

'重新返回操作表
Sheets(currentSheetName).Select

 '一维表标题要手动加上
 
 '一维表行自增量，新表从第二行开始写入，第一行为手工填写标行
 Dim i As Integer
 i = 2
  '一维表列自增量
 Dim j As Integer
 j = 1
 
 '最大行数
 Dim maxRow As Integer
 maxRow = ActiveSheet.Range("A65535").End(xlUp).Row
 
  '最大列数
 Dim maxColumn As Integer
 maxColumn = ActiveSheet.Range("IV1").End(xlToLeft).Column
 
 '行标标题数
 Dim rowTitles As Integer
 rowTitles = InputBox("请填写行标题数： ", "行标题数")
 
 '列标题数
 Dim columnTitles As Integer
 columnTitles = InputBox("请填写列标题数： ", "输入列标题数")
 
 
 '遍历内容行数
 For rowCurrentI = rowTitles + 1 To maxRow
 
        '遍历内容列数
        For colCurrentI = columnTitles + 1 To maxColumn
            
            '遍历列标题内容
            For colunmTitleCurrentI = 1 To columnTitles
                Sheets(resultSheetName).Cells(i, j) = ActiveSheet.Cells(rowCurrentI, colunmTitleCurrentI)
                j = j + 1
            Next
            
            '遍历行标题内容
            For rowTitleCurrentI = 1 To rowTitles
             Sheets(resultSheetName).Cells(i, j) = ActiveSheet.Cells(rowTitleCurrentI, colCurrentI)
                j = j + 1
            Next
            
            '取得交叉内容区数据
            Sheets(resultSheetName).Cells(i, j) = ActiveSheet.Cells(rowCurrentI, colCurrentI)
                        
            '新表换行
            j = 1
            i = i + 1
         Next
    Next
    MsgBox ("转换完毕")
    
End Sub

五、需要改进，现在以宏的方式运行的，程序代码工作薄文件，换个文件就不存在了。可以考虑以插件形式。

在这里插入图片描述
更新：

  '取得交叉内容区数据,如无数据则不作处理，用下一个有数据单元格替换
            If (Not IsEmpty(Sheets(currentSheetName).Cells(rowCurrentI, colCurrentI))) Then
		            Sheets(resultSheetName).Cells(i, j) = Sheets(currentSheetName).Cells(rowCurrentI, colCurrentI)
		            '新表换行
		            j = 1
		            i = i + 1
              Else
           			 j = 1
              End If