关于批量增加Excel表格行高的VBA代码修改求助

tds828

quqiyuan 发表于 2024-6-22 17:25
检查过，有增加行高。。。
Sub 批量AutoFitAll_1()
    Application.ScreenUpdating = False

能不能麻烦你一下，就是我想把表格的打印区域设置为有有效内容的页面，无内容的其他页面不打印，也就是放在调整行高后进行打印区域设置，

quqiyuan

tds828 发表于 2024-6-25 15:38
能不能麻烦你一下，就是我想把表格的打印区域设置为有有效内容的页面，无内容的其他页面不打印，也就是放 ...

供参考。。。


打印区域

tds828

感谢楼上各位的帮忙，基本上满足需要了

tds828

quqiyuan 发表于 2024-6-25 19:49
供参考。。。

我可能没有表达清楚我的意思，我的意思是有有效内容的那个页面设置为打印区域，类似于图中所表现的情况，不是有有效内容的行设置为打印区域。

quqiyuan

tds828 发表于 2024-7-2 16:24
我可能没有表达清楚我的意思，我的意思是有有效内容的那个页面设置为打印区域，类似于图中所表现的情况， ...

你这样不好设定打印区域，如果就只有一页可能好点，如果好多页，不好弄。

tds828

quqiyuan 发表于 2024-7-2 18:56
你这样不好设定打印区域，如果就只有一页可能好点，如果好多页，不好弄。

那好吧，谢谢大神的帮助，已经做的非常满意了，我再从模板的角度去考虑一下打印区域设置的问题，继续给你加分。

quqiyuan

tds828 发表于 2024-7-5 15:51
那好吧，谢谢大神的帮助，已经做的非常满意了，我再从模板的角度去考虑一下打印区域设置的问题，继续给你 ...

其实昨晚还想了一下你这个需求，但是没想到你还需要，我马上处理一下，想法是最后一行的区域总共有多少打印页面，然后循环在后面加行数，如果超过原有页面，停止，然后提取加的行数，就可以解决这个问题，可能啰嗦点，但是我也只是想到这个方法。马上去改一下代码。。。

quqiyuan

改了下，希望是你需要，后面会增加空白行。。。

quqiyuan

代码如下。。。


Sub 批量AutoFitAll_1()
    Application.ScreenUpdating = False
    Dim sh As String
    Dim MyPath, MyName, AWbName
    Dim mysheet As Worksheet
    MyPath = ThisWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls*")
    AWbName = ThisWorkbook.Name
    Num = 0
Do While MyName <> ""
    If MyName <> AWbName Then
        Set wb = Workbooks.Open(MyPath & "\" & MyName)
        Num = Num + 1
        For Each mysheet In wb.Worksheets
            With mysheet
                For i = 1 To .Cells(.Rows.Count, 1).End(3).Row                    '.UsedRange.Rows.Count,由于usedrange下面没有用的行过多，改用了以第一列有数据为准，仅供参考
                    If Application.WorksheetFunction.CountA(.Rows(i)) > 0 Then
                        .Rows(i).RowHeight = .Rows(i).RowHeight + 4
                    End If
                Next i
                r = .Cells(.Rows.Count, 1).End(3).Row
                .PageSetup.PrintArea = "$A$1:$H$" & r                               '以A列有数据为最后的行，H列区域为打印的区域
                x = .PageSetup.Pages.Count                              'excel工作表打印的总页数
                For i = 1 To 100                                         '最后一页填充满工作表，所以需要一行一行尝试，不超过原来的总页数即可
                    .PageSetup.PrintArea = "$A$1:$H$" & r + i
                    y = .PageSetup.Pages.Count
                    If y > x Then Exit For
                Next
                .PageSetup.PrintArea = "$A$1:$H$" & r + i - 1
            End With
            wb.Save
        Next mysheet
        WbN = WbN & Chr(13) & wb.Name
        wb.Close False
    End If
    MyName = Dir
Loop
    MsgBox "共调整" & Num & "个工作薄下全部工作表的行高和列宽。如下：" & Chr(13) & WbN, vbInformation, "提示"
    Application.ScreenUpdating = True
End Sub

tds828

quqiyuan 发表于 2024-7-5 16:13
代码如下。。。

非常感谢，完全符合要求了，这样我的工作效率就又提高了，可以抽空摸鱼了。