办公室实用VBA小程序之代码部分(三)

1、办公室实用VBA小程序之代码（2）摘要： 本部分是办公室实用VBA小程序（一）的各项功能的具体代码，现分享给大家。 2、常用功能区代码：Sub一键打印()ProgressBar1.Visible = TrueApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseProgressBar1.Min = 0ProgressBar1.Max = Sheets.CountIf MsgBox("是否已经全部调整好打印格式？", vbYesNo, "警告") = vbYes Then Fo

2、r Each Mysht In Worksheets Mysht.PrintOut ActivePrinter:="Ricoh Aficio MP 2550B PCL 在 Ne00:" cot = cot + 1 ProgressBar1.Value = cot Next Application.ScreenUpdating = TrueElse Exit SubEnd IfLabel2.Caption = "打印完毕,共打印" & cot & "张。"cot = 0End Sub'显示被隐藏的工作表Sub 显

3、示隐藏表()Application.ScreenUpdating = FalseFor Each Mysht In ActiveWorkbook.Worksheets If Mysht.Visible <> xlSheetVisible Then Mysht.Visible = xlSheetVisible cot = cot + 1 End IfNext If cot > 0 Then Label2.Caption = "已显示" & cot & "张被隐藏的工作表。" Else Label2.Caption = &q

4、uot;该Workbook中无被隐藏的工作表。" End If cot = 0 Application.ScreenUpdating = TrueEnd Sub'隐藏非活动工作表Sub 隐藏非活表()For Each Mysht In ActiveWorkbook.Worksheets If Mysht.Name <> ActiveSheet.Name Then Mysht.Visible = xlSheetHidden cot = cot + 1 End IfNext If cot > 0 Then Label2.Caption = "已隐藏&q

5、uot; & cot & "张非活动工作表。" Else Label2.Caption = "该Workbook中已无非活动工作表。" End If cot = 0End SubSub 取消合并单元格()For Each rng In ActiveSheet.UsedRange.Cells If rng.MergeCells = True Then rng.UnMerge End IfNextLabel2.Caption = "所有合并单元格取消完毕！"End SubSub 查找清除空格()Dim rng As Ran

6、geIf MsgBox("是否在查找后进行替换？", vbYesNo, "提醒您:") = vbYes Then On Error Resume Next For Each rng In ActiveSheet.UsedRange If InStr(1, rng, Chr(32) Then rng.Replace What:=Chr(32), Replacement:="" rng.Interior.Color = vbYellow cot = cot + 1 End If Next' Unload UserForm2 If

7、cot = 0 Then UserForm2.Label2.Caption = "定位完毕，本表中无空格！" Else UserForm2.Label2.Caption = "共有" & cot & "个单元格含有空格，已黄色显示并替换！" End If Else For Each rng In ActiveSheet.UsedRange On Error Resume Next If InStr(1, rng, Chr(32) Then rng.Interior.Color = vbYellow cot = cot

8、+ 1 End If Next' Unload UserForm2 If cot = 0 Then UserForm2.Label2.Caption = "定位完毕，本表中无空格！" Else UserForm2.Label2.Caption = "定位完毕，共有" & cot & "个单元格含有空格,已用黄色标示！" End IfEnd Ifcot = 0End SubOption ExplicitPublic Sub 标记选区重复值() On Error Resume Next Dim rn As Rang

9、e, first As Range Dim ColorIdx As Integer Dim d Set d = CreateObject("scripting.dictionary") Selection.Interior.ColorIndex = 2 ColorIdx = 0 For Each rn In Selection If rn <> "" Then If d.exists(rn.Value) Then Set first = Range(d(rn.Value) '第一次出现的单元格 If first.Interior.Co

10、lorIndex = 2 Then '第一次出现时 未设置过颜色 '- ColorIdx = (ColorIdx + 1) Mod 56 + 1 '颜色可选范围：056 If ColorIdx = 2 Then ColorIdx = 3 '- first.Interior.ColorIndex = ColorIdx Else ColorIdx = first.Interior.ColorIndex End If rn.Interior.ColorIndex = ColorIdx Else d.Add rn.Value, rn.Address End If End

11、 If NextEnd SubSub 另存WB() Dim Wb As Workbook Mypath = ActiveWorkbook.Path Set Mysht = ActiveSheet Set Wb = Workbooks.Add Mysht.Copy before:=Wb.Worksheets(1) 'wb.Worksheets(1).Name = MySht.Name Wb.SaveAs Mypath & "" & Mysht.Name & ".xlsx" Wb.Close Label2.Caption =

12、"已将该Sheet单独保存在：" & MypathEnd SubSub 全部另存WB() Dim Wb As Workbook Mypath = ActiveWorkbook.Path Application.ScreenUpdating = False ProgressBar1.Max = ActiveWorkbook.Worksheets.Count For Each Mysht In ActiveWorkbook.Worksheets Set Wb = Workbooks.Add Mysht.Copy before:=Wb.Worksheets(1) '

13、;wb.Worksheets(1).Name = MySht.Name cot = cot + 1 Wb.SaveAs Mypath & "" & Mysht.Name & ".xlsx" Wb.Close ProgressBar1.Value = cot Next Application.ScreenUpdating = True Label2.Caption = "已将全部工作表单独保存在：" & Mypath cot = 0End SubSub 显示所有隐行()Dim i, ii As Doubl

14、eFor i = 1 To ActiveSheet.UsedRange.Rows.Count If ActiveSheet.Rows(i).Hidden = True Then ActiveSheet.Rows(i).Hidden = False ii = ii + 1 End IfNextLabel2.Caption = "显示完毕,共" & ii & "行。"End SubSub 显示所有隐列()Dim i, ii As DoubleFor i = 1 To ActiveSheet.UsedRange.Columns.Count If

15、 ActiveSheet.Columns(i).Hidden = True Then ActiveSheet.Columns(i).Hidden = False ii = ii + 1 End IfNextLabel2.Caption = "显示完毕,共" & ii & "列。"End SubOption ExplicitSub 消除选区重复值() On Error Resume Next Dim rn As Range, res Dim tar Dim d Set d = CreateObject("scripting.dictionary") For Each rn In Selection If rn <> "" And Not d.exists(rn.Value) Then d.Add rn.Value, "" Next res = d.keys 'For i = 0 To d.Count - 1 'Cells(i + 1, 5) = res(i) 'Next Set tar = Application.InputBox(prompt:="