VBA跨Excel工作薄，按照Excel工作表样板表行高、列宽值调整目标工作表行高、列宽

点击观看视频效果

文章目录

• 前言
• • 1.数字转字母
  • 2.获取单元格行高
  • 3.获取单元格列宽
  • 4.调整行高、列宽

前言

格式刷在我们调整Excel工作表、Word文档的格式时经常使用到，它可以帮助我们快速批量调整字体、大小、颜色、背景色等，甚至是表格行高列宽、字间距大小等。但如果在不同的Excel工作薄或跨Word文档，格式刷却不能使用。
用VBA代码，将样板工作表的行高、列宽的值保存在三维数组内，再按数组值依次调整目标工作表行高、列宽。

1.数字转字母

Public Function GetEngName(argColumn As Integer) As String  '数字转字母
    Dim strEngName As String
    Dim iNum, iMod As Integer

    iNum = argColumn \ 26
    iMod = argColumn Mod 26
    If (iMod = 0) Then
        If (iNum = 1) Then
            strEngName = Chr(90)
        Else
            strEngName = Chr(65 + iNum - 2) + Chr(90)
        End If
    Else
        If (iNum = 0) Then
            strEngName = Chr(65 + iMod - 1)
        Else
            strEngName = Chr(65 + iNum - 1) + Chr(65 + iMod - 1)
        End If
    End If
    GetEngName = strEngName
End Function

2.获取单元格行高

Function getRowSize(rngRow As Integer, rngCol As Integer) As Integer   '获取单元格行高
    Dim RowHeight As Double
    Dim ColA As String
    ColA = GetEngName(rngCol)
    ColWidth = ActiveSheet.Range(ColA & rngRow).ColumnWidth
    RowHeight = ActiveSheet.Range(ColA & rngRow).RowHeight
    getRowSize = RowHeight
End Function

3.获取单元格列宽

Function getColSize(rngRow As Integer, rngCol As Integer) As Integer   '获取单元格列宽
    Dim ColWidth As Double
    Dim ColA As String
    Dim rng As Range
 '   rngRow = rng.Row
 '   rngCol = rng.Column
    ColA = GetEngName(rngCol)
    ColWidth = ActiveSheet.Range(ColA & rngRow).ColumnWidth
    getColSize = ColWidth
End Function

4.调整行高、列宽

Sub setRCHW()
  Call findRC("样板表", "Sheet4", "目标表", "Sheet1")
End Sub

Function findRC(YuWorkBook As String, yuanSheet As String, MuWorkBook As String, MuSheet As String)
 Dim rowscount As Integer
 Dim ColsCount As Integer
 Dim RCHW() As Integer
 Dim i As Integer, j As Integer
 Dim folderPath As String
 Dim fname As String
 Dim fPath As String
 Dim wb1Path As String
 Dim wb2Path As String
 On Error Resume Next
 Application.DisplayAlerts = False
 folderPath = Application.ActiveWorkbook.Path
 fname = ThisWorkbook.Name
 fPath = Replace(folderPath, fname, "")
 wb1Path = fPath & "/" & YuWorkBook & ".xls"
 wb2Path = fPath & "/" & MuWorkBook & ".xls"
 Workbooks.Open Filename:=wb1Path '打开工作薄1
 Windows(YuWorkBook).Activate
 Sheets(yuanSheet).Activate
 rowscount = Sheets(yuanSheet).UsedRange.Rows.Count
 ColsCount = Sheets(yuanSheet).UsedRange.Columns.Count
 ReDim RCHW(rowscount, ColsCount, 2)
 Sheets(yuanSheet).Activate
 For i = 1 To rowscount
   RCHW(i, 1, 0) = getRowSize(i, 1)
 Next
 For j = 1 To ColsCount
   RCHW(1, j, 1) = getColSize(1, j)
 Next
 Workbooks.Open Filename:=wb2Path '打开工作薄2
 Windows(MuWorkBook).Activate
 Sheets(MuSheet).Activate
    For i = 1 To rowscount
      Sheets(MuSheet).Cells(i, 1).RowHeight = RCHW(i, 1, 0)
    Next
    For j = 1 To ColsCount
      Sheets(MuSheet).Cells(1, j).ColumnWidth = RCHW(1, j, 1)
    Next
End Function