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

tds828

在一个文件夹下游很多个Excel文件，我需要先dir一下文件列表，单后打开每个文件，先给有内容的行增加行高4，保存，目前整合了两段代码，但是打开文件后运行代码，并没有对所有Excel文件修改行高，只修改了批量增加行高文件中的行高，大神们能不能帮忙看看代码哪里出错了。

tds828

Sub 批量AutoFitAll()
    Application.ScreenUpdating = False
    Dim sh As String
    Dim MyPath, MyName, AWbName
    Dim mysheet As Worksheet
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls")
    AWbName = ActiveWorkbook.Name
    Num = 0
Do While MyName <> ""
    If MyName <> AWbName Then
        Set wb = Workbooks.Open(MyPath & "\" & MyName)
        Num = Num + 1
        sh = ActiveSheet.Name
    For Each mysheet In ActiveWorkbook.Worksheets
        mysheet.Activate
        Application.ScreenUpdating = False
        Cells.EntireRow.AutoFit
    For i = 1 To ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
        If Application.WorksheetFunction.CountA(Rows(i)) > 0 Then
            Rows(i).RowHeight = Rows(i).RowHeight + 4
        End If
    Next i
    Application.ScreenUpdating = True
        ActiveWorkbook.Save
    Next mysheet
        Sheets(sh).Select
        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

1. Sub 批量AutoFitAll()
   
2.     Application.ScreenUpdating = False
   
3.     Dim sh As String
   
4.     Dim MyPath, MyName, AWbName
   
5.     Dim mysheet As Worksheet
   
6.     MyPath = ActiveWorkbook.Path
   
7.     MyName = Dir(MyPath & "" & "*.xls")
   
8.     AWbName = ActiveWorkbook.Name
   
9.     Num = 0
   
10. Do While MyName <> ""
    
11.     If MyName <> AWbName Then
    
12.         Set wb = Workbooks.Open(MyPath & "" & MyName)
    
13.         Num = Num + 1
    
14.         sh = ActiveSheet.Name
    
15.     For Each mysheet In ActiveWorkbook.Worksheets
    
16.         mysheet.Activate
    
17.         Application.ScreenUpdating = False
    
18.         Cells.EntireRow.AutoFit
    
19.     For i = 1 To ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    
20.         If Application.WorksheetFunction.CountA(Rows(i)) > 0 Then
    
21.             Rows(i).RowHeight = Rows(i).RowHeight + 4
    
22.         End If
    
23.     Next i
    
24.     Application.ScreenUpdating = True
    
25.         ActiveWorkbook.Save
    
26.     Next mysheet
    
27.         Sheets(sh).Select
    
28.         WbN = WbN & Chr(13) & wb.Name
    
29.         wb.Close False
    
30.     End If
    
31.     MyName = Dir
    
32. Loop
    
33.     MsgBox "共调整" & Num & "个工作薄下全部工作表的行高和列宽。如下：" & Chr(13) & WbN, vbInformation, "提示"
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

蓝桥玄霜

批量的例子：

quqiyuan

这个是改动过的，供参考。。。

quqiyuan

检查过，有增加行高。。。
Sub 批量AutoFitAll_1()
    Application.ScreenUpdating = False
    Dim sh As String
    Dim MyPath, MyName, AWbName
    Dim mysheet As Worksheet
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls*")
    AWbName = ActiveWorkbook.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 .UsedRange.Rows.Count
                    If Application.WorksheetFunction.CountA(.Rows(i)) > 0 Then
                        .Rows(i).RowHeight = .Rows(i).RowHeight + 4
                    End If
                Next i
            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

感谢楼上两位，我测试一下看看。

tds828

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

确实可以用了，感谢大神帮忙。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.22
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     For Each f In fso.GetFolder(p).Files
   
7.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
8.             Set wb = Workbooks.Open(f, 0)
   
9.             For Each sht In wb.Sheets
   
10.                 With sht
    
11.                     r = .UsedRange.Rows.Count
    
12.                     If r > 1 Then
    
13.                         For i = 1 To r
    
14.                             .Rows(i).RowHeight = .Rows(i).RowHeight + 4
    
15.                         Next
    
16.                     End If
    
17.                 End With
    
18.             Next
    
19.             wb.Close 1
    
20.         End If
    
21.     Next f
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK!"
    
24. End Sub
    

复制代码