MagicDad

19
05

合并单元格自动调整行高小工具【加载宏】

EXCEL单元格格式设置中的“自动调整行高”功能，对于合并单元格并不适合。
手动进行调整的话，可以用一个文本框的自动适合文字的设置，来得到合适的总高度，然后把这个总高度按合并单元格的行数进行均分，以此设置它们的行高。
但是，上述手动 操 作效率很低，如果表格中的合并单元格很多的话，那就会非常麻 烦。

在“以人为本”的思想为指导下，这种麻 烦 事，还是交给电脑来做吧！

附件使用方法：很简单的，
      把附件中的宏工作薄用EXCEL打开，再另存为 加载宏 格式（后缀名为.xlam），保存在EXCEL默认的加载宏文件夹下，然后在“开发工具”选项卡上点“加载项”按钮，在弹出的对话框中，把“合并单元格自动行高”勾选上就可以了。
      当你在合并单元格中编辑完成切换到其它单元格时，该程序就会自动运行。无论合并单元格字体的名称、大小是什么，它都能完成任务。

更新内容：
1、程序运行过程中，不再在当前的活动工作薄中添加、删除文本框和其它任何对象，以免影响到活动工作薄中的文本框命名。需要得到合并单元格最合适的行高时，直接使用预置于加载宏工作薄内的文本框，在对用户无任何打扰的情况下完成任务，做到“随风潜入夜，润物细无声”。
2、直接提供做好的加载宏。

模块1：

    1. PrivateConst LOGPIXELSX =88

    2. PrivateConst LOGPIXELSY =90

    3. PrivateConst TWIPSPERINCH =1440

    4. #If Win64 And VBA7 Then

    5. PublicDeclarePtrSafeFunctionGetDCLib"user32"(ByVal hWnd AsLong)AsLong

    6. PublicDeclarePtrSafeFunctionGetDeviceCapsLib"gdi32"(ByVal hDC AsLong,ByVal nIndex AsLong)AsLong

    7. PublicDeclarePtrSafeFunctionReleaseDCLib"user32"(ByVal hWnd AsLong,ByVal hDC AsLong)AsLong

    8. #Else

    9. PublicDeclareFunctionGetDCLib"user32"(ByVal hWnd AsLong)AsLong

    10. PublicDeclareFunctionGetDeviceCapsLib"gdi32"(ByVal hDC AsLong,ByVal nIndex AsLong)AsLong

    11. PublicDeclareFunctionReleaseDCLib"user32"(ByVal hWnd AsLong,ByVal hDC AsLong)AsLong

    12. #End If

    13.  

    14. Public DPI

    15. Public myMergeAreaAddress AsString

    16. Public myMergeAreaRowheights AsString

    17. Public ht AsSingle

    18. Public vtAlign AsExcel.Constants

    19. PublicWrapTxtAsBoolean

    20. PublicKeyOnAsBoolean

    21.  

    22. Function getDPI(bX AsBoolean)AsInteger'获取屏幕分辨率

    23.     Dim hDC As Long, RetVal As Long

    24.     hDC = GetDC(0)

    25.     If bX = True Then

    26.         getDPI = GetDeviceCaps(hDC, LOGPIXELSX)

    27.     Else

    28.         getDPI = GetDeviceCaps(hDC, LOGPIXELSY)

    29.     End If

    30.     RetVal = ReleaseDC(0, hDC)

    31. End Function

    32.  

    33. Sub Undo_MergeAreaRowsAutofit()

    34.     With Range(myMergeAreaAddress)

    35.        .VerticalAlignment = vtAlign

    36.        rc = .Rows.Count

    37.         rh = Split(myMergeAreaRowheights, ",")

    38.         For i = 1 To rc

    39.             .Rows(i).RowHeight = rh(i)

    40.         Next

    41.     End With

    42.     Application.OnRepeat "恢复'合并单元格自动行高'操作", "Repeat_MergeAreaRowsAutofit"

    43. End Sub

    44.  

    45. Sub Repeat_MergeAreaRowsAutofit()

    46.     With Range(myMergeAreaAddress)

    47.         .EntireRow.RowHeight = ht                                   '根据平均高度设置行高

    48. .VerticalAlignment= xlCenter                               '设置垂直方向居中对齐

    49.         .WrapText = True                                            '设置自动换行

    50. EndWith

    51. Application.OnUndo"撤销'合并单元格自动行高'操作","Undo_MergeAreaRowsAutofit"

    52. EndSub

    53.  

    54. Sub开关自动行高()

    55. KeyOn=NotKeyOn

    56.  

    57. MsgBox"合并单元格自动行高功能已经"&IIf(KeyOn,"开启！","关闭！")

    58. IfNotKeyOnThen

    59. ThisWorkbook.Close

    60. ElseIfIsEmpty(DPI)Then

    61.         DPI = getDPI(1)

    62. EndIf

    63. EndSub


 
ThisWorkbook模块： 

    1. PublicWithEventsExcelAppAsExcel.Application

    2. Private tbx AsShape

    3.  

    4. PrivateSubExcelApp_SheetChange(ByValShAsObject,ByValTargetAsRange)

    5. Dim sobj AsObject,RngAsRange

    6. IfNotKeyOnThenExitSub

    7. IfTarget.MergeCellsThen'如果是所选单元格为合并单元格

    8.         Set myMergeArea = Target.Cells(1).MergeArea                                                '获取合并单元格所在区域

    9. If myMergeArea.Cells(1)=""ThenExitSub'合并单元格为空时跳出过程

    10.         '保存合并单元格的位置、大小、及其字体的名字、大小

    11. With myMergeArea

    12.             myMergeAreaAddress =.Address'获取合并单元格地址信息

    13.             vtAlign = .VerticalAlignment                                                           '设置合并单元格对齐方式为垂直居中对齐

    14.             wdth =.Next.Offset(,.Rows(1).Count).Left-.Left

    15. Debug.Print myMergeAreaAddress

    16.             rc =.Rows.Count'获取合并单元格行数

    17.             myMergeAreaRowheights = ""

    18.             For i = 1 To rc

    19.                 myMergeAreaRowheights = myMergeAreaRowheights & "," & .Rows(i).RowHeight           '记录合并单元格每行“历史”行高

    20. Next

    21. SetRng=ThisWorkbook.Sheets(1).Range("A1")'设置当前工作簿的第一个工作表的 A1 单元格为 Rng 对象

    22.             cc = .Columns.Count                                                                    '获取合并单元格列数

    23. KeyOn=False

    24. .CopyRng'将合并单元格内容临时存放于 Rng 中

    25.             KeyOn = True

    26.             Rng.UnMerge                                                                            '设置Rng区域为非合并单元格

    27. Rng.WrapText=True'设置 Rng 区域文本自动换行

    28.             For i = 1 To cc

    29.                 cwd = cwd + .Cells(1, i).ColumnWidth                                               '计算合并单元格区域字符数（每个单元格0-255）

    30.                 wd = wd +.Cells(1, i).Width'计算合并单元格区域磅宽度（1磅 = 0.35毫米）

    31.             Next

    32.             Rng.ColumnWidth = cwd                                                                  '将合并单元格字符数宽度赋值给Rng列宽

    33. '计算 Rng 区域真实应为宽度

    34.             Do

    35.                 ws = Rng.Width - wd                                                                '单元格之间默认线宽为0.375字符数

    36. If ws >=0ThenExitDo

    37.                 cwd = cwd - ws * DPI /72*0.127'72是每英寸的Point个数，0.127毫米是1英寸的1/200。（1英寸 = 25.4毫米 ）

    38.                 Rng.ColumnWidth = cwd

    39.             Loop

    40.             Rng.EntireRow.AutoFit                                                                  '根据Rng列宽，通过自动换行获取行高

    41.             ht =(Rng.RowHeight+IIf(rc >5,5,2))/ rc                                          '计算合并单元格平均高度

    42.             Repeat_MergeAreaRowsAutofit

    43.         End With

    44.         Application.OnUndo "撤销'合并单元格自动行高'操作", "Undo_MergeAreaRowsAutofit"

    45.     End If

    46. End Sub

    47. Private Sub Workbook_BeforeClose(Cancel As Boolean)

    48.     ThisWorkbook.Saved = True

    49.     'Application.AddIns(Split(ThisWorkbook.Name,".")(0)).Installed=False

    50. EndSub

    51. PrivateSubWorkbook_Open()

    52. SetExcelApp=ThisWorkbook.Application

    53. EndSub


-------------------------------------------------------------

合并单元格自动调整行高小工具【加载宏】 更新2018-1-4

https://club.excelhome.net/thread-1389572-1-1.html

(出处: ExcelHome技术论坛)


● OFFICE技巧

评论

© MagicDad | Powered by LOFTER