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

1/11办公室实用VBA小程序之代码（2）摘要：本部分是办公室实用VBA小程序（一）的各项功能的具体代码，现分享给大家。2、常用功能区代码：Sub一键打印()ProgressBar1.Visible=TrueApplication.ScreenUpdating=FalseApplication.DisplayAlerts=FalseProgressBar1.Min=0ProgressBar1.Max=Sheets.CountIfMsgBox(是否已经全部调整好打印格式？,vbYesNo,警告)=vbYesThen2/11ForEachMyshtInWorksheetsMysht.PrintOutActivePrinter:=RicohAficioMP2550BPCL在Ne00:cot=cot+1ProgressBar1.Value=cotNextApplication.ScreenUpdating=TrueElseExitSubEndIfLabel2.Caption=打印完毕,共打印&cot&张。cot=0EndSub'显示被隐藏的工作表Sub显示隐藏表()Application.ScreenUpdating=FalseForEachMyshtInActiveWorkbook.WorksheetsIfMysht.VisiblexlSheetVisibleThenMysht.Visible=xlSheetVisiblecot=cot+1EndIfNext3/11Ifcot0ThenLabel2.Caption=已显示&cot&张被隐藏的工作表。ElseLabel2.Caption=该Workbook中无被隐藏的工作表。EndIfcot=0Application.ScreenUpdating=TrueEndSub'隐藏非活动工作表Sub隐藏非活表()ForEachMyshtInActiveWorkbook.WorksheetsIfMysht.NameActiveSheet.NameThenMysht.Visible=xlSheetHiddencot=cot+1EndIfNextIfcot0ThenLabel2.Caption=已隐藏&cot&张非活动工作表。ElseLabel2.Caption=该Workbook中已无非活动工作表。EndIfcot=04/11EndSubSub取消合并单元格()ForEachrngInActiveSheet.UsedRange.CellsIfrng.MergeCells=TrueThenrng.UnMergeEndIfNextLabel2.Caption=所有合并单元格取消完毕！EndSubSub查找清除空格()DimrngAsRangeIfMsgBox(是否在查找后进行替换？,vbYesNo,提醒您:)=vbYesThenOnErrorResumeNextForEachrngInActiveSheet.UsedRangeIfInStr(1,rng,Chr(32))Thenrng.ReplaceWhat:=Chr(32),Replacement:=rng.Interior.Color=vbYellowcot=cot+1EndIfNext'UnloadUserForm25/11Ifcot=0ThenUserForm2.Label2.Caption=定位完毕，本表中无空格！ElseUserForm2.Label2.Caption=共有&cot&个单元格含有空格，已黄色显示并替换！EndIfElseForEachrngInActiveSheet.UsedRangeOnErrorResumeNextIfInStr(1,rng,Chr(32))Thenrng.Interior.Color=vbYellowcot=cot+1EndIfNext'UnloadUserForm2Ifcot=0ThenUserForm2.Label2.Caption=定位完毕，本表中无空格！ElseUserForm2.Label2.Caption=定位完毕，共有&cot&个单元格含有空格,已用黄色标示！EndIfEndIf6/11cot=0EndSubOptionExplicitPublicSub标记选区重复值()OnErrorResumeNextDimrnAsRange,firstAsRangeDimColorIdxAsIntegerDimdSetd=CreateObject(scripting.dictionary)Selection.Interior.ColorIndex=2ColorIdx=0ForEachrnInSelectionIfrnThenIfd.exists(rn.Value)ThenSetfirst=Range(d(rn.Value))'第一次出现的单元格Iffirst.Interior.ColorIndex=2Then'第一次出现时未设置过颜色'----------------------------------7/11ColorIdx=(ColorIdx+1)Mod56+1'颜色可选范围：0~56IfColorIdx=2ThenColorIdx=3'----------------------------------first.Interior.ColorIndex=ColorIdxElseColorIdx=first.Interior.ColorIndexEndIfrn.Interior.ColorIndex=ColorIdxElsed.Addrn.Value,rn.AddressEndIfEndIfNextEndSubSub另存WB()DimWbAsWorkbookMypath=ActiveWorkbook.PathSetMysht=ActiveSheetSetWb=Workbooks.AddMysht.Copybefore:=Wb.Worksheets(1)8/11'wb.Worksheets(1).Name=MySht.NameWb.SaveAsMypath&\&Mysht.Name&.xlsxWb.CloseLabel2.Caption=已将该Sheet单独保存在：&MypathEndSubSub全部另存WB()DimWbAsWorkbookMypath=ActiveWorkbook.PathApplication.ScreenUpdating=FalseProgressBar1.Max=ActiveWorkbook.Worksheets.CountForEachMyshtInActiveWorkbook.WorksheetsSetWb=Workbooks.AddMysht.Copybefore:=Wb.Worksheets(1)'wb.Worksheets(1).Name=MySht.Namecot=cot+1Wb.SaveAsMypath&\&Mysht.Name&.xlsxWb.CloseProgressBar1.Value=cotNextApplication.ScreenUpdating=TrueLabel2.Caption=已将全部工作表单独保存在：&Mypath9/11cot=0EndSubSub显示所有隐行()Dimi,iiAsDoubleFori=1ToActiveSheet.UsedRange.Rows.CountIfActiveSheet.Rows(i).Hidden=TrueThenActiveSheet.Rows(i).Hidden=Falseii=ii+1EndIfNextLabel2.Caption=显示完毕,共&ii&行。EndSubSub显示所有隐列()Dimi,iiAsDoubleFori=1ToActiveSheet.UsedRange.Columns.CountIfActiveSheet.Columns(i).Hidden=TrueThenActiveSheet.Columns(i).Hidden=Falseii=ii+1EndIfNext10/11Label2.Caption=显示完毕,共&ii&列。EndSubOptionExplicitSub消除选区重复值()OnErrorResumeNextDimrnAsRange,resDimtarDimdSetd=CreateObject(scripting.dictionary)ForEachrnInSelectionIfrnAndNotd.exists(rn.Value)Thend.Addrn.Value,Nextres=d.keys'Fori=0Tod.Count-1'Cells(i+1,5)=res(i)'NextSettar=Application.InputBox(prompt:=请选择存放结果的单元格(存放不重复序列,按列)。,Title:=结果存放,Type:=8)IftarIsNothingThenExitSubEndIf11/11tar.Resize(d.Count)=WorksheetFunction.Transpose(d.keys)'Cells(1,11).Resize(d.Count)=WorksheetFunction.Transpose(d.keys)EndSub