[原创]表格VBA行列转置代码

守柔

本月的竞赛题,要求在WORD中对表格进行行列转置,最简单的方法莫过于使用EXCEL的选择性粘贴了,WORD中常规法也可以,我做了一个,KONNGS兄的方法也不错. 发这个主题贴的目的,是进一步提高大家对于WORD中表格的认识及对于数组应用的一些相关知识. 相关链接: http://club.excelhome.net/dispbbs.asp?boardID=104&ID=148763&page=1 '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I LOVE YOU WORD!@ExcelHome 2006-2-25 8:26:16 '仅测试于System: Windows NT Word: 11.0 Language: 2052 '№ 0024^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Option Explicit Sub TableTranspose() '表格行列转置 Dim myTable As Table, myRange As Range, myString As String Dim myArray() As String, aArray As Variant, CR() As String Dim RowCount As Integer, ColCount As Integer, R As Integer, C As Integer Dim Times As Single Times = VBA.Timer '当前时间数 With Selection '如果光标不位于表格中或者没有选定表格则退出程序 If Not .Information(wdWithInTable) Then MsgBox "Word没有找到光标处的表格,请重新选定表格!", vbExclamation: Exit Sub Set myTable = .Tables(1) '定义一个表格对象 End With With myTable '如果表格有合并的列或者行,提示 If .Uniform = False Then MsgBox "表格中含有合并单元格,Word无法进行正确的行列转置!", vbExclamation: Exit Sub myString = .Range.Text '取得表格中的文本 ColCount = .Columns.Count '取得表格列数 RowCount = .Rows.Count '取得表格行数 .Delete '删除表格 Set myRange = Selection.Range '取得光标所在位置的RANGE对象 End With '如果当前表格最大行数超过63,则提示 If RowCount > 63 Then MsgBox "表格的列数超过63,Word无法进行正确的行列转置", vbExclamation: Exit Sub ReDim CR(1 To ColCount, 1 To RowCount) '声明一个下标为1的(列数*行数)动态二维数组 myArray = VBA.Split(myString, Chr(7)) '以CHR(7)--单元格分隔竖线为分隔符返回一个数组 myString = "" '从内存中初始化变量 C = 1: R = 1 '初始化变量,对应数组下标 For Each aArray In myArray '在数组中循环 If C <= ColCount Then '如果C<=表格列数 CR(C, R) = aArray '向数组赋值 Else If R = RowCount Then Exit For '如果R=表格行数时退出循环 R = R + 1: C = 0 'R递加,C归零(相当于循环到表格的下一行时,行号增加,列数归零) End If C = C + 1 '列数递加 Next For C = 1 To ColCount '二维数组中建立一个循环,相当于在各值中取值 For R = 1 To RowCount '建立一个循环 myString = myString & CR(C, R) '取得数组值,此处实现转置 Next Next myRange.InsertAfter myString '插入文本 '文本转化为表格 Set myTable = myRange.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=RowCount, NumRows:=ColCount) myTable.Style = "网格型" '设置表格样式 Debug.Print Timer - Times End Sub

海洋微风

studing

konggs

学习ing

konggs

这地方：

C = 1: R = 1 '初始化变量,对应数组下标
For Each aArray In myArray '在数组中循环
If C <= ColCount Then '如果C<=表格列数
CR(C, R) = aArray '向数组赋值
Else
If R = RowCount Then Exit For '如果R=表格行数时退出循环
R = R + 1: C = 0 'R递加,C归零(相当于循环到表格的下一行时,行号增加,列数归零)
End If
C = C + 1 '列数递加
Next

卡了一下，主要就是C = 1: R = 1这种用法，没见过啊，能说说吗？老大。

还有就是：为什么不直接用上面的循环得到数组转置后的结果？

谢谢。

雨雪霏霏

　　有没有办法把已经设置了字体格式、表格边框颜色的表格进行转换，转换后的表格会自动保持相应格式？ 　　这问题可能问得太刁，不过，实在是小弟现实中经常遇到的问题，在此向大家求助！ 　　附件中共有五个问题，都是在测试了守柔兄的宏后总结的。烦请点击详察。 SygAySvz.rar (22.02 KB, 下载次数: 105)

2006-5-17 23:10 上传

点击文件名下载附件
[原创]表格VBA行列转置代码

我爱myvba

我把代码这样分行：
Sub TableTranspose() '表格行列转置
    Dim myTable As Table, myRange As Range, myString As String
    Dim myArray() As String, aArray As Variant, CR() As String
    Dim RowCount As Integer, ColCount As Integer, R As Integer, C As Integer
    Dim Times As Single
    Times = VBA.Timer '当前时间数
With Selection '如果光标不位于表格中或者没有选定表格则退出程序
    If Not .Information(wdWithInTable) Then
       MsgBox "Word没有找到光标处的表格,请重新选定表格!", vbExclamation: Exit Sub
    Set myTable = .Tables(1) '定义一个表格对象
End With
With myTable '如果表格有合并的列或者行,提示
     If .Uniform = False Then
        MsgBox "表格中含有合并单元格,Word无法进行正确的行列转置!", vbExclamation: Exit Sub
     myString = .Range.Text '取得表格中的文本
     ColCount = .Columns.Count '取得表格列数
     RowCount = .Rows.Count '取得表格行数
     .Delete '删除表格
     Set myRange = Selection.Range '取得光标所在位置的RANGE对象
End With '如果当前表格最大行数超过63,则提示
    If RowCount > 63 Then
        MsgBox "表格的列数超过63,Word无法进行正确的行列转置", vbExclamation: Exit Sub
   ReDim CR(1 To ColCount, 1 To RowCount) '声明一个下标为1的(列数*行数)动态二维数组
   myArray = VBA.Split(myString, Chr(7)) '以CHR(7)--单元格分隔竖线为分隔符返回一个数组
   myString = "" '从内存中初始化变量
   C = 1: R = 1 '初始化变量,对应数组下标
For Each aArray In myArray '在数组中循环
      If C <= ColCount Then '如果C<=表格列数
         CR(C, R) = aArray '向数组赋值
      Else: If R = RowCount Then Exit For '如果R=表格行数时退出循环
         R = R + 1: C = 0 'R递加,C归零(相当于循环到表格的下一行时,行号增加,列数归零)
     End If
     C = C + 1 '列数递加
Next
For C = 1 To ColCount '二维数组中建立一个循环,相当于在各值中取值
For R = 1 To RowCount '建立一个循环
        myString = myString & CR(C, R) '取得数组值,此处实现转置
Next
Next
     myRange.InsertAfter myString '插入文本 '文本转化为表格
     Set myTable = myRange.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=RowCount, NumRows:=ColCount)
     myTable.Style = "网格型" '设置表格样式
     Debug.Print Timer - Times
End Sub

运行后为什么有这样的提示？

我爱myvba

经实验，如果某单元格中有多个段落，转置错误：

ltz888

好资料，很有点用处哦

wmdcmlsx

各位大侠：小弟是个VBA菜鸟，想请各位大侠帮帮手，VBA行列转置。效果如附件

ak47ok

每次回帖、谢谢！