在Excel工作簿复制内容格式以及打印的参数设置

作者：梁小铭

当然手工也可实现 ，但使用VBA可批量自动化实现这个工作，如果这个工作经常要做的话，用代码可以大大提高效率

 Sub CopyFormat(BytNum As Byte) '复制内容格式以及打印的参数设置     Dim sht As Worksheet, newsht As Worksheet, wkb As Workbook, newbook As Workbook On Error GoTo errline     Application.Visible = False '隐藏主程序        Set wkb = ActiveWorkbook '当前活动工作簿     Set newbook = Workbooks.Add '创建工作簿     '路径和保存的工作簿名称自行设置     newbook.SaveAs Filename:=wkb.Path & "\" & "复制.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled           'BytNum参数的值是0的话则复制当前区域的内容和格式     'BytNum参数的值是1的话则复制整表  If BytNum = 0 Then     For Each sht In wkb.Worksheets             Set newsht = newbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) '              newsht.Name = "1" '新建的工作表自己自行取名字                '先复制当前区域，整行复制才能把行高一同复制过去                sht.Range("a1").CurrentRegion.EntireRow.Copy newsht.Range("a1")                 newsht.Activate '必须先激活工作表才能进行列宽粘帖                sht.Range("a1").CurrentRegion.Copy '复制当前区域的内容和格式                '选择性粘帖列宽格式                 newsht.Range("a1").CurrentRegion.PasteSpecial Paste:=xlPasteColumnWidths                 Call PageSetup(newsht, sht) '设置打印参数（页边距等）     Next      ElseIf BytNum = 1 Then       For Each sht In wkb.Worksheets               sht.Copy After:=newbook.Worksheets(Worksheets.Count) '复制整表到新的工作簿里               Set newsht = newbook.ActiveSheet '把新复制的工作表赋值给变量newsht                '              newsht.Name = "1" '新建的工作表自己自行取名字        Call PageSetup(newsht, sht) '设置打印参数（页边距等）     Next           End If                errline:     Application.Visible = True '恢复显示主程序 End Sub Function PageSetup(NewPageSht As Worksheet, OldPageSht As Worksheet) '设置打印参数（页边距等）      With NewPageSht           .PageSetup.Orientation = xlLandscape              '横向           .PageSetup.Orientation = OldPageSht.PageSetup.Orientation          '打印方向           .PageSetup.LeftMargin = OldPageSht.PageSetup.LeftMargin             '左边距           .PageSetup.RightMargin = OldPageSht.PageSetup.RightMargin           '右边距           .PageSetup.TopMargin = OldPageSht.PageSetup.TopMargin              '上边距           .PageSetup.BottomMargin = OldPageSht.PageSetup.BottomMargin        '下边距           .PageSetup.HeaderMargin = OldPageSht.PageSetup.HeaderMargin         '页眉           .PageSetup.FooterMargin = OldPageSht.PageSetup.FooterMargin         '页角           .PageSetup.PrintTitleColumns = OldPageSht.PageSetup.PrintTitleColumns '         .PageSetup.PrintTitleRows = "$1:$5"   '顶端标题行 '         .Protect Password:="ljc", DrawingObjects:=True, Contents:=True, Scenarios:=True                               End With End Function Sub text() '测试代码 Rem  BytNum参数的值是0的话则复制当前区域的内容和格式 Rem  BytNum参数的值是1的话则复制整表  Call CopyFormat(1) End Sub 上次写的复制区域行高，列宽，以及打印区域设置