清除多簿之表中空行

ddz79101

老师！我希望对文件夹（路径不确定）下多簿中的表之空行，进行清除。轻轻老师指点。谢谢

lln0618

Sub 依次打开文件夹里所有的表格()

Application.DisplayAlerts = False '取消弹出框
Dim myPath$, myFile$, AK As Workbook

myPath = Application.ActiveWorkbook.Path & "\"  '当前文件路径
myFile = Dir(myPath & "*.xls*") '依次寻找xls文件

Do While myFile <> "" '当指定路径中有文件时进行循环
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile) '打开符合要求的文件

'-------------自定义的程序---------------------------------

For i = 1 To Worksheets.Count '遍历所有工作簿

Worksheets(i).Activate  '激活表格工作簿
hs = Range("A65536").End(xlUp).Row '获取A列最后一行行号
For j = hs To 2 Step -1  '行删除
If Range("A" & j) = "" Then
Rows(j).Delete
End If
Next

Next



'----------------------------------------------------------

AK.Save '表格保存
AK.Close '表格关闭
End If
myFile = Dir '寻找下一个文件
Loop

Application.DisplayAlerts = True '取消弹出框
End Sub

文件.zip (49.41 KB, 下载次数: 4)

2024-5-23 14:29 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.5.23   删除空行
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .Title = "请选择文件夹"
   
8.         .InitialFileName = ThisWorkbook.Path & ""
   
9.         If .Show = -1 Then
   
10.             p = .SelectedItems(1) & ""
    
11.         End If
    
12.     End With
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If f.Name Like "*.xls*" Then
    
15.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
16.                 fn = fso.GetBaseName(f)
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 With wb.Sheets(1)
    
19.                     r = .UsedRange.Rows.Count
    
20.                     Set Rng = Nothing
    
21.                     For i = 1 To r
    
22.                         If Application.WorksheetFunction.CountA(.Rows(i)) = 0 Then
    
23.                             If Rng Is Nothing Then
    
24.                                 Set Rng = .Rows(i)
    
25.                             Else
    
26.                                 Set Rng = Union(Rng, .Rows(i))
    
27.                             End If
    
28.                         End If
    
29.                     Next i
    
30.                     If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
31.                 End With
    
32.                 wb.Close 1
    
33.             End If
    
34.         End If
    
35.     Next f
    
36.     Application.ScreenUpdating = True
    
37.     Application.DisplayAlerts = True
    
38.     MsgBox "OK！"
    
39. End Sub
    

复制代码

ddz79101

有老师帮忙吗？我主要想删除假空行。但，文件夹路径选择，深入工作表清除空行。我遇到困难，

ykcbf1100

ykcbf1100 发表于 2024-5-23 15:14
附件供参考。。。

。。。。。。。。。。。。

ykcbf1100

lln0618 发表于 2024-5-23 14:29
Sub 依次打开文件夹里所有的表格()

Application.DisplayAlerts = False '取消弹出框

是空行，不是A列为空的行

ddz79101

lln0618 发表于 2024-5-23 14:29
Sub 依次打开文件夹里所有的表格()

Application.DisplayAlerts = False '取消弹出框

谢谢老师！

ddz79101

ykcbf1100 发表于 2024-5-23 15:14
附件供参考。。。

谢谢老师！

usedrange

Sub t()
    Dim i%, m, s, arr, r%, fso, fs, sh, brr, mpath, wb
    mpath = "E:\VBA\清除文件夹下各表中的行\文件"    '这个要修改一下路径
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fs = fso.getfolder(mpath).Files
    For Each f In fs
        Set wb = Workbooks.Open(f)
        With wb.ActiveSheet
            arr = .UsedRange
            r = .[iv1].End(xlToLeft).Column
            For i = UBound(arr) To 1 Step -1
                If .Range("a" & i) = "" Then
                    brr = .Range("a" & i).Resize(1, r)
                    Set sh = .Range("a" & i & ":n" & i)
                    s = sh.Sort(Range("a" & i), 1, , , , , Orientation:=xlSortRows)
                    If .Range("a" & i) = "" Then
                        Rows(i).Delete
                    Else
                        .Range("a" & i).Resize(1, r) = brr
                    End If
                End If
            Next i
            wb.Save
            wb.Close
            Set wb = Nothing
        End With
    Next f
    Set fs = Nothing
    Set fso = Nothing
End Sub