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

genuinechenfp

没排版么？好乱~

derien

正在学习，非常有用

乐乐2006201505

我爱myvba 发表于 2009-12-26 16:06
我把代码这样分行：
Sub TableTranspose() '表格行列转置
    Dim myTable As Table, myRange As Range,  ...

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 If
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