批量删除多个excel文件的指定行和指定列

shiiki

有几十个excel文件要求同时删除表1中前3行和第2,4,5列的数据，附件1文件有效果。

baofa2

操作簿.zip (39.66 KB, 下载次数: 14)

2024-5-8 13:49 上传

点击文件名下载附件

ykcbf1100

数组法。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.8
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     b = [{1,3,6}]
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.             fn = fso.GetBaseName(f)
    
11.             m = 0
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets("Sheet1")
    
14.                 r = .Cells(Rows.Count, 1).End(3).Row
    
15.                 arr = .[a1].Resize(r, 6)
    
16.                 .UsedRange = ""
    
17.                 ReDim brr(1 To UBound(arr), 1 To 3)
    
18.                 For i = 4 To UBound(arr)
    
19.                     m = m + 1
    
20.                     For j = 1 To UBound(b)
    
21.                     brr(m, j) = arr(i, b(j))
    
22.                     Next
    
23.                 Next
    
24.                 .[a1].Resize(m, 3) = brr
    
25.             End With
    
26.             wb.Close 1
    
27.         End If
    
28.     Next f
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
32. End Sub
    

复制代码

Qs18

Sub test()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim fileExtension As String
    Dim filePattern As String
    Dim fileNumber As Integer
    Dim lastRow As Long
    Dim lastColumn As Integer
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    ' 设置文件夹路径和文件扩展名
    folderPath = ThisWorkbook.Path & "\"
    fileExtension = "*.xlsx" ' Excel文件扩展名，可以是*.xls*或*.xlsx等
   
    ' 构建文件模式字符串，例如 "*.xls*" 匹配所有Excel文件
    filePattern = Dir(folderPath & fileExtension)
   
    ' 遍历文件夹中的所有Excel文件
  
    Do While filePattern <> ""
     If filePattern <> ThisWorkbook.FullName Then
        ' 构建完整的文件路径
        fileName = folderPath & filePattern
        
        ' 打开工作簿
        Set wb = Workbooks.Open(fileName)
        
        ' 检查是否有工作表
        If wb.Sheets.Count > 0 Then
            ' 假设我们要操作第一个工作表
            Set ws = wb.Sheets(1)
            ' 删除前三行
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            If lastRow > 3 Then
                ws.Range("A1:A" & 3).EntireRow.Delete
            End If
            
            ' 删除第二、四、五列
            ws.Columns(5).Delete
            ws.Columns(4).Delete
            ws.Columns(2).Delete
            
            ' 保存并关闭工作簿
            wb.Close (True)
        End If
        
        ' 获取下一个文件名
        filePattern = Dir()
End If
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ' 消息提示完成
    MsgBox "所有文件处理完成！", vbInformation
End Sub

沈默00

参与一下.....

浦东坡

1. Sub 跨工作表删除指定行列()
   
2.     Dim wk As Workbook
   
3.     Dim sht As Worksheet
   
4.     Dim nam
   
5.     Dim ss$, i%
   
6.     ss = "G:\练习\批量删除行列\1.xlsx"
   
7.     nam = Dir("G:\练习\批量删除行列\*.xlsx")
   
8.     Do While nam <> ""
   
9.         Set wk = Workbooks.Open("G:\练习\批量删除行列" & nam)
   
10.         For i = 1 To wk.Sheets.Count
    
11.                 Sheets(i).Rows("1:3").Delete
    
12.                 Sheets(i).Columns("b:b").Delete
    
13.                 Sheets(i).Columns("d:e").Delete
    
14.         Next i
    
15.         wk.Close (False) '"false"为调试程序用,实际使用填"true""
    
16.         nam = Dir() '选取下一个文件,括号内保持为空
    
17.     Loop
    
18. End Sub
    
19. 修改路径可直接使用

复制代码