vba开发

yivifu

利用vba实现将excel表格左转90度复制到指定位置

在编辑较长word文档的时候，如果文件中有很宽的表格，这时一般需要在文档中插入分节符，将插入表格的那一节设置为横向页面。如果能够将横向表格直接转换成纵向表格，那么就不需改变页面方向，插入页码页眉页脚什么的都比较方便。在word中手工将一个横向表格改成纵向，不但输入工作量大，也容易出错。比较方便的方法是将表格拷贝到excel中，用VBA宏把表格左旋90度，修改单元格文字方向后再拷回word。以下宏代码可将excel表格中某个区域的内容左旋90度复制到指定的其他区域，可供参考：

Sub test()

Dim srcTotalColumns As Integer '源区域总列数，多列合并为1列的，仍然算多列
Dim srcTotalRows As Integer '源区域总行数，多行合并为1行的，仍然算多行
Dim srcStartRow As Integer '源区域左上单元格行号
Dim srcStartColumn As Integer '源区域左上单元格列号

Dim destStartColumn As Integer '目标区域左上单元格列号
Dim destStartRow As Integer '目标区域左上单元格行号

'临时变量，i、j分别是目标区域行列指针，m、n分别是源区域行列指针
Dim i As Integer, j As Integer, m As Integer, n As Integer

'根据实际情况给各变量赋值。这个宏移植到其他地方使用时只需修改以下六个变量的赋值
    srcTotalColumns = 6: srcTotalRows = 4: srcStartColumn = 3: srcStartRow = 5
    destStartColumn = 12: destStartRow = 7
   
'源区域由右上角开始遍历
    m = srcStartRow
    n = srcStartColumn  + srcTotalColumns -1
'目标区域由左上角开始遍历。向左旋转90度后源区域右上角单元格刚好移动到目标区域左上角单元格
    For j = destStartColumn To (destStartColumn + srcTotalRows - 1)
         For i = destStartRow To (destStartRow + srcTotalColumns - 1)
            ActiveSheet.Cells(i, j) = "=" & ColNum2Letter (n) & m
            n = n - 1
        Next i
        m = m + 1
        n = srcStartColumn + srcTotalColumns -1
Next j
'目标区域由左上角开始遍历。 采取while循环，与上面的for循环等价，注释掉
'j = destStartColumn
'     While (j < (destStartColumn + srcTotalRows))
'         i = destStartRow
'         While (i < (destStartRow + srcTotalColumns))
'            ActiveSheet.Cells(i, j) = "=" & ColNum2Letter (n) & m
'            n = n - 1: i = i + 1
'        Wend
'        m = m + 1
'        n = srcStartColumn + srcTotalColumns - 1
'        j = j + 1
'     Wend
  
End Sub

'用辗转相除法将数字列号转换为字母列号的函数，例如列“100”转换为"CV"，ByVal重要，防止参数值被修改
Function ColNum2Letter(ByVal iCol As Integer) As String
   Dim i As Integer, j As Integer
   Dim res(4) As String 'excel当前发行版本中最大列号只有三个字母，4个元素的数组足够了
  i = 0
   While (iCol > 0)
        i = i + 1
        If (iCol Mod 26) = 0 Then
            res(i) = "Z"
        Else
            res(i) = Chr((iCol Mod 26) + 64)
        End If        
        If (iCol Mod 26) = 0 Then
            iCol = Int(iCol / 26) - 1
        Else
            iCol = Int(iCol / 26)
        End If        
   Wend
   For j = i To 1 Step -1
        ColNum2Letter = ColNum2Letter & res(j)
   Next j
End Function


这个宏的好处是以后修改表格中横向区域的内容时纵向区域的内容会自动跟着更新，只要区域大小和结构不发生变化，不需再次运行宏，就可以直接拷贝纵向区域的内容。但是，源区域中的空白单元格复制到目标区域后会显示0，源区域中的合并单元格拷贝到目标区域后还需要手工合并，这些都需要进一步完善。

上述宏运行示例效果图（目标区域中的那些0以及合并单元格的情况尚需手工处理）：




如果源区域行列数难数，则只需选择源区域，运行下面的代码记下行列数即可：
MsgBox "列数=" & Selection.Columns.Count & vbCrLf & "行数=" & Selection.Rows.Count

继续改进，这次的代码只需选中源区域后运行即可，移植时不需再修改代码。提醒用户输入指定目标区域左上单元格时，给出的参考单元格是源区域右下单元格斜右下方空出一行一列的位置，主要是为了设置目标区域文字方向后调整单元格高度与宽度时不影响源区域的单元格高度与宽度。用户需注意目标区域不要有数据，否则会被破坏。

Sub excel左旋90度拷贝()
Dim srcTotalColumns As Integer '源区域总列数，多列合并为1列的，仍然算多列
Dim srcTotalRows As Integer '源区域总行数，多行合并为1行的，仍然算多行
Dim srcStartRow As Integer '源区域左上单元格行号
Dim srcStartColumn As Integer '源区域左上单元格列号

Dim destStartColumn As Integer '目标区域左上单元格列号
Dim destStartRow As Integer '目标区域左上单元格行号

'临时变量，i、j分别是目标区域行列指针，m、n分别是源区域行列指针

Dim i As Integer, j As Integer, m As Integer, n As Integer


'记录合并单元格所占的行数和列数的变量，未合并的单元格视为占1行1列
Dim mergeRows As Integer, mergeColumns As Integer

mergeRows = 1: mergeColumns = 1


'必须将源区域全部选中后再运行这个宏，根据选择区域自动初始化源区域有关参数
   srcTotalColumns = Selection.Columns.Count
   srcTotalRows = Selection.Rows.Count
   srcStartColumn = Selection.Column
   srcStartRow = Selection.Row
   
   destStartColumn = Application.InputBox(Prompt:="请输入目标区域左上单元格列号，参考列号为" & _
        srcStartColumn + srcTotalColumns + 1, Title:="输入列号", Type:=1)
   destStartRow = Application.InputBox(Prompt:="请输入目标区域左上单元格行号，参考行号为" & _
        srcStartRow + srcTotalRows + 1, Title:="输入行号", Type:=1)


'源区域由右上角开始按行遍历，即自右向左，自上向下
    m = srcStartRow
    n = srcStartColumn + srcTotalColumns - 1

    '目标区域由左上角开始按行遍历。向左旋转90度后源区域右上角单元格刚好移动到目标区域左上角单元格
    j = destStartColumn
     While (j < (destStartColumn + srcTotalRows))
        i = destStartRow
       While (i < (destStartRow + srcTotalColumns))
'源区域当前单元格为合并单元格且其上面的单元格地址与当前单元格的地址不同（即不在同一个合并区域中），则目标区域执行合并操作
          If ActiveSheet.Cells(m, n).MergeCells Then
                mergeRows = ActiveSheet.Cells(m, n).MergeArea.Rows.Count
                mergeColumns = ActiveSheet.Cells(m, n).MergeArea.Columns.Count
                If m = 1 Then
                    ActiveSheet.Range(ColNum2Letter(j) & i & ":" & ColNum2Letter(j + mergeRows - 1) & (i + mergeColumns - 1)).Merge
                Else
                   If ActiveSheet.Range(ColNum2Letter(n) & m).MergeArea.Address <> _
                           ActiveSheet.Range(ColNum2Letter(n) & (m - 1)).MergeArea.Address Then
                        ActiveSheet.Range(ColNum2Letter(j) & i & ":" & ColNum2Letter(j + mergeRows - 1) & (i + mergeColumns - 1)).Merge
                    End If
                End If
          Else
                mergeRows = 1: mergeColumns = 1
           End If
          If mergeColumns > 1 Then

                n = n - mergeColumns + 1

           End If

           '下面这样可以保留引用关系，运行一次宏后，只要源区域表格结构不变，修改源区域后目标区域自动更新，不需再运行宏
            ActiveSheet.Cells(i, j) = "=" & ColNum2Letter (n) & m
           n = n - 1
           i = i + mergeColumns

       Wend

       m = m + 1

       n = srcStartColumn + srcTotalColumns - 1

       j = j + 1

    Wend

End Sub

顺便再记录一个函数，不过这个函数实用性不大，完全可以不用函数调用，而直接使用类似代码：
'将字母列号转为数字。用65536，是因为那个单元格不大可能被使用，不会由于单元格合并导致column属性值不对
Function ColLetter2Num(colLetter As String) As Integer
    ColLetter2Num = Range(colLetter & 65536).Column
End Function

yivifu

改进版。宏运行后才要求选择复制区域，而且是用鼠标圈选。目标区域也由用户以鼠标圈选。目标区域可以选择不同的工作表或不同工作薄中的区域。


Sub excel左旋90度拷贝()
Dim srcTotalColumns As Integer '源区域总列数，多列合并为1列的，仍然算多列
Dim srcTotalRows As Integer '源区域总行数，多行合并为1行的，仍然算多行
Dim srcStartRow As Integer '源区域左上单元格行号
Dim srcStartColumn As Integer '源区域左上单元格列号

Dim destStartColumn As Integer '目标区域左上单元格列号
Dim destStartRow As Integer '目标区域左上单元格行号

'临时变量，destRowPtr、destColPtr分别是目标区域行列指针，srcRowPtr、srcColPtr分别是源区域行列指针
Dim destRowPtr As Integer, destColPtr As Integer, srcRowPtr As Integer, srcColPtr As Integer

'记录合并单元格所占的行数和列数的变量，未合并的单元格视为占1行1列
Dim mergeRows As Integer, mergeColumns As Integer
mergeRows = 1: mergeColumns = 1

Dim srcBook As Workbook, destBook As Workbook, srcSheet As Worksheet, destSheet As Worksheet, _
            srcRng As Range, destRng As Range, srcSheetName$, destSheetName$

'复制操作如跨工作表或工作薄，需要在公式前面加上工作薄或工作表名称。numFormat定义单元格格式
Dim preNames$, numFormat
preNames = "": numFormat = "0.00;-0.00;;@"

'等待用户选择要复制的区域
Set srcRng = Application.InputBox(Prompt:="请选择要复制的区域", Type:=8)
srcTotalColumns = srcRng.Columns.Count
srcTotalRows = srcRng.Rows.Count
srcStartColumn = srcRng.Column
srcStartRow = srcRng.Row
Set srcSheet = srcRng.Parent
Set srcBook = srcSheet.Parent
srcSheetName = srcSheet.Name

    '等待用户选择要复制到的区域
   Set destRng = Application.InputBox(Prompt:="请选择目标区域左上单元格", Type:=8)
   Set destSheet = destRng.Parent
   Set destBook = destSheet.Parent
   destSheetName = destSheet.Name
   destStartColumn = destRng.Column
   destStartRow = destRng.Row

   If destBook.Name <> srcBook.Name Then
    preNames = "[" & srcBook.Name & "]" & srcSheetName & "!"
   End If
  
   If preNames = "" And destSheet.Name <> srcSheet.Name Then
    preNames = srcSheetName & "!"
   End If

    '给用户一个反悔的机会
    If MsgBox("请注意复制是否会破坏已有数据。点击“确定”开始复制，点击“取消”中止操作。", _
                                        Buttons:=vbOKCancel, Title:="警告") = 2 Then
        Exit Sub
    End If

'源区域由右上角开始按行遍历，即自右向左，自上向下
    srcRowPtr = srcStartRow
    srcColPtr = srcStartColumn + srcTotalColumns - 1

    '目标区域由左上角开始按行遍历。向左旋转90度后源区域右上角单元格刚好移动到目标区域左上角单元格
    destColPtr = destStartColumn
     While (destColPtr < (destStartColumn + srcTotalRows))
        destRowPtr = destStartRow
        While (destRowPtr < (destStartRow + srcTotalColumns))
'源区域当前单元格为合并单元格且其上面的单元格地址与当前单元格的地址不同（即不在同一个合并区域中），
' 则目标区域执行合并操作
            With srcSheet
                If .Cells(srcRowPtr, srcColPtr).MergeCells Then
                     mergeRows = .Cells(srcRowPtr, srcColPtr).MergeArea.Rows.Count
                     mergeColumns = .Cells(srcRowPtr, srcColPtr).MergeArea.Columns.Count
                     If srcRowPtr = 1 Then
                       destSheet.Range(ColNum2Letter(destColPtr) & destRowPtr & ":" & _
                                    ColNum2Letter(destColPtr + mergeRows - 1) & (destRowPtr + mergeColumns - 1)).Merge
                     Else
                         If .Range(ColNum2Letter(srcColPtr) & srcRowPtr).MergeArea.Address <> _
                                .Range(ColNum2Letter(srcColPtr) & (srcRowPtr - 1)).MergeArea.Address Then
                            destSheet.Range(ColNum2Letter(destColPtr) & destRowPtr & ":" & ColNum2Letter(destColPtr + _
                                                                mergeRows - 1) & (destRowPtr + mergeColumns - 1)).Merge
                         End If
                     End If
                Else
                     mergeRows = 1: mergeColumns = 1
                End If
               
                If mergeColumns > 1 Then
                     srcColPtr = srcColPtr - mergeColumns + 1
                End If

               destSheet.Cells(destRowPtr, destColPtr) = "=" & preNames & ColNum2Letter(srcColPtr) & srcRowPtr
                srcColPtr = srcColPtr - 1
                destRowPtr = destRowPtr + mergeColumns
           End With
       Wend
       srcRowPtr = srcRowPtr + 1
       srcColPtr = srcStartColumn + srcTotalColumns - 1
       destColPtr = destColPtr + 1
    Wend

        destBook.Activate
        destSheet.Activate
       With destSheet.Range(ColNum2Letter(destStartColumn) & destStartRow & ":" & ColNum2Letter(destColPtr - 1) & _
                        (destRowPtr - 1))
        .Orientation = 90
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        .NumberFormatLocal = numFormat
        .Select
       End With

End Sub

zhanglei1371

个人认为，在word中通过遍及每个表格，判断表格长度，分别添加分节符并自动设置横向比这个容易的多吧。而且若表格有些区域有颜色，用上面代码估计会清楚掉

yivifu

有时候，我需要添加页眉页脚，而且做成一本书，人家还要求那个页眉页脚非放在纵向的上下方不可。这就是我把word文档全部页面都设置成纵向的原因。表格区的颜色问题，我也写过《word文档全部表格风格统一》，对于我来说还不成问题。至于难度，写这个宏花了点功夫，运行它却比设置横向页面要容易得多，最关键的是过了把写代码的瘾。