|
|
楼主 |
发表于 2024-6-10 13:07
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 OKJSJSF 于 2024-6-10 22:32 编辑
四肢发达头脑简单，发现还是忘了一个判断条件，宜补充。数据所在行单元格的选择不宜在列标题上方。
Sub cb240(control As IRibbonControl) '全行数据一览无余2，列数过多的数据记录分左右二栏展示，便于打印成一页A4
If Workbooks.Count = 0 Then
MsgBox "没有可操作的工作簿。", vbExclamation, "微软的提醒：" '如果只剩加载宏工作簿则其功能禁用
Exit Sub
End If
Dim r As Range, c1 As Byte, c2 As Byte, s1 As String, s2 As String
On Error GoTo errline
Do
Set r = Application.InputBox("请选择打印区域列标题的第一个单元格：", "参数设置1", , , , , , 8)
If TypeName(Intersect(r, r.Parent.UsedRange)) <> "Range" Or Len(r) = 0 Then '列标题应当有文本
MsgBox "无效选择！", vbQuestion, "微软的提醒："
Else
Exit Do
End If
Loop
Application.ScreenUpdating = False
With r
s1 = .Parent.Name '单元格的父对象就是工作表
c1 = .Column
c2 = .End(xlToRight).Column - c1 + 1 '打印范围的左上角单元格可自已确定，不一定非得第一个
.Resize(1, c2).EntireColumn.Hidden = False '隐藏的列必须显示后才能被下一步复制
.Resize(1, c2).Copy
End With
Worksheets.Add
s2 = ActiveSheet.Name '新建工作表即是活动工作表，不用管它什么名称，赋给变量即可
Cells(2).PasteSpecial xlPasteValuesAndNumberFormats, xlPasteSpecialOperationNone, False, True '选择性粘贴值与数字格式并转置
Cells(1) = 1
Cells(1).DataSeries rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=c2 '填充自然数作为序号
With Worksheets(s1)
.Activate '用程序激活或选择就不必手工切换工作表，速度大增
Application.ScreenUpdating = True
Do
Set r = Application.InputBox("请选择一个数据所在行单元格：", "参数设置2", , , , , , 8)
If r.Row > .UsedRange.Row + .UsedRange.Rows.Count-1 Or r.Row < .UsedRange.Row + 1 Then '已用区域的第一行+行数-1=末行
MsgBox "无效选择！", vbQuestion, "微软的提醒："
Else
Exit Do
End If
Loop
Application.ScreenUpdating = False
Cells(r.Row, c1).Resize(1, c2).Copy
Set r = Nothing
End With
Worksheets(s2).Activate '再次切换工作表
Cells(3).PasteSpecial xlPasteValuesAndNumberFormats, xlPasteSpecialOperationNone, False, True
Cells(1).CurrentRegion.Borders.LineStyle = xlContinuous '首单元格所属区域添加细边框
Cells(4).Select
If c2 > 50 Then 'A4纸打印时宜50列以内，再多宜分二栏排版
If c2 Mod 2 = 0 Then
Cells(c2 / 2 + 1, 1).Resize(c2 / 2, 3).Cut
Else
Cells(c2 / 2 + 1.5, 1).Resize(c2 / 2 + 0.5, 3).Cut
End If
ActiveSheet.Paste
Cells(1).Resize(Cells(1).End(xlDown).Row, 3).Borders(xlEdgeRight).LineStyle = xlDouble '分栏时中间用双垂线更美观
Cells(7).Select
End If
Cells.EntireColumn.AutoFit '工作表列宽自动调整
Application.ScreenUpdating = True
MsgBox "执行完毕，请预览。"
Application.Dialogs(xlDialogPrintPreview).Show '弹出打印预览对话框，与ActiveWindow.SelectedSheets.PrintPreview相同，WPS只能这句
errline:
End Sub |
|
楼主: OKJSJSF
沪公网安备 31011702000001号 沪ICP备11019229号-2
