对文件夹中的所有文件运行VBA excel宏

Question

我面临的一个问题是，我的宏适用于单个excel工作簿，需要能够适用于文件夹中的所有工作簿。该宏执行多项操作：1(打开工作簿中的所有工作表并将其保存到特定位置2(如果图形存在，则将图形的标题提取到T99 3(删除任何列包含关键字("数据"(之前的所有行。它运行得很好，但我有100本工作簿，我想在上面运行这个宏。

这是原始宏：

Sub b2()
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String
Dim fRg As Range

Set wbThis = ThisWorkbook
For Each ws In wbThis.Worksheets
strFilename = wbThis.Path & "/singlesheets/" & ws.Name
ws.Copy
Set wbNew = ActiveWorkbook
On Error Resume Next
Sheets(1).ChartObjects(1).Activate

If Err.Number <> 0 Then
Else
Worksheets(1).Range("T99").Value = Worksheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
End If
Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)

If Not fRg Is Nothing Then
If fRg.Row <> 1 Then
Range("A1", fRg.Offset(-1)).EntireRow.Delete
Else
End If
Else
End If
wbNew.SaveAs strFilename
wbNew.Close
Next ws
End Sub

这是我的无效模块，它在同一工作簿上重复执行上述宏，但不会继续到文件夹中的下一个工作簿：

Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'your code here
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String
Dim fRg As Range
Set wbThis = ThisWorkbook
For Each ws In wbThis.Worksheets
strFilename = wbThis.Path & "/singlesheets/" & ws.Name
ws.Copy
Set wbNew = ActiveWorkbook
On Error Resume Next
Sheets(1).ChartObjects(1).Activate
If Err.Number <> 0 Then
Else
Worksheets(1).Range("T99").Value = Worksheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text
End If
Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole)

If Not fRg Is Nothing Then
If fRg.Row <> 1 Then
Range("A1", fRg.Offset(-1)).EntireRow.Delete
Else
End If
Else
End If
wbNew.SaveAs strFilename
wbNew.Close
Next ws
End With
xFileName = Dir
Loop
End If
End Sub

Answer 1

正如注释中所指出的，如果您创建的方法不做太多事情，那么管理代码会更容易。。。

Sub ProcessFolder()
Dim xFd As FileDialog, xFdItem As Variant, xFileName As String
Dim wb As Workbook

Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.AllowMultiSelect = False
If xFd.Show <> -1 Then Exit Sub

xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""

Set wb = Workbooks.Open(xFdItem & xFileName)
ProcessWorkbook wb 'export all sheets
wb.Close False

xFileName = Dir() 'next file
Loop
End Sub
Sub ProcessWorkbook(wb As Workbook)
Dim ws As Worksheet, fRg As Range
Dim wsNew As Worksheet

For Each ws In wb.Worksheets
ws.Copy
Set wsNew = ActiveWorkbook.Worksheets(1) 'get the copied sheet

On Error Resume Next 'ignore any chart/chart title error
wsNew.Range("T99").Value = wsNew.ChartObjects(1).Chart.ChartTitle.Text
On Error GoTo 0

Set fRg = wsNew.Cells.Find(What:="datum", LookAt:=xlWhole)
If Not fRg Is Nothing Then
If fRg.Row > 1 Then wsNew.Range("A1", fRg.Offset(-1)).EntireRow.Delete
End If
'save and close the sheet copy
wsNew.Parent.SaveAs wb.Path & "/singlesheets/" & ws.Name ' & ".xlsx" ?
wsNew.Parent.Close False
Next ws
End Sub