用VBA解析多个Excel工作簿

Question

我不擅长VBA（我典型的用例是录制宏，清理和修改VBA而不是从头开始创建任何东西）。我试图在使用Kutools整合它们之前，减少约300本excel工作簿。

我想出了一点vba来剥离这些工作簿的一些不必要的部分，以使我的整合。

Sub PrepWorkbook() 
    Dim Sh As Worksheet 
    For Each Sh In ThisWorkbook.Worksheets 
     If Sh.Visible = True Then 
      Sh.Activate 
      Sh.Cells.Copy 
      Sh.Range("A1").PasteSpecial Paste:=xlValues 
      Sh.Range("A1").Select 
     End If 
    Next Sh 
    Application.CutCopyMode = False 
     Dim ws As Worksheet 

    For Each ws In Worksheets 
     ws.Cells.Validation.Delete 
    Next ws 
    Application.DisplayAlerts=FALSE 
    Sheets("Instructions").Delete 
    Sheets("Dropdowns").Delete 
    Sheets("Dropdowns2").Delete 
    Sheets("Range Reference").Delete 
    Sheets("All Fields").Delete 
    Sheets("ExistingData").Delete 
    Application.DisplayAlerts=TRUE 
End Sub 

我发现的代码极好位上的计算器跨多个工作簿，我试图适应我的目的，行驶了预定任务：

当任何单独的工作簿上运行此代码的工作没有问题

Sub ProcessFiles() 
    Dim Filename, Pathname As String 
    Dim wb As Workbook 

    Pathname = ActiveWorkbook.Path & "\Files\" 
    Filename = Dir(Pathname & "*.xls") 
    Do While Filename <> "" 
     Set wb = Workbooks.Open(Pathname & Filename) 
     DoWork wb 
     wb.Close SaveChanges:=True 
     Filename = Dir() 
    Loop 
End Sub 


Sub DoWork(wb As Workbook) 
    With wb 
     'Do your work here 
     .Worksheets(1).Range("A1").Value = "Hello World!" 
    End With 
End Sub 

原来的线程可以在这里找到： Run same excel macro on multiple excel files

我试着将我的代码放到了““在这里做你的工作”和”.Worksheets（1）.Range（‘A1’）的价值。 =“Hello World！”“行原来的vba，但没有成功。我也试过类似地将我的解析代码插入到几个其他解决方案中，以跨多个excel工作簿执行宏，但没有成功。

它调用的工作簿正在打开和保存，但我的代码正在尝试完成的实际工作没有发生（没有记录错误）。我怀疑我插入的一段代码是不兼容的，这对于比我更有知识的人来说是非常明显的。

任何人都可以提供一些帮助/指导吗？我真的只需要代码或指导如何在“C：\ Temp \ Workbooks”中找到的300个工作簿上执行原始“PrepWorkbook”VBA

Answer 1

在您的第一部分代码中，您必须对齐变量使用THISWORKBOOK，因为它可以将它隔离到它的运行位置。在评论中使用'PG'。我也不认为你需要在第二个宏中使用'WITH WB代码。你的第一个循环通过你的床单。

改变宏的名称为清楚起见

Sub DoWork(wb As Workbook) 
Dim Sh As Worksheet 
For Each Sh In wb.Sheets'PG adjustments 
    If Sh.Visible = True Then 
     Sh.Activate 
     Sh.Cells.Copy 
     Sh.Range("A1").PasteSpecial Paste:=xlValues 
     Sh.Range("A1").Select 
    End If 
Next Sh'PG adjustments 
Application.CutCopyMode = False 
    Dim ws As Worksheet 

For Each ws In wb.Sheets 'PG seems redundant to above, but harmless. 
    ws.Cells.Validation.Delete 
Next ws 
Application.DisplayAlerts=FALSE 
Sheets("Instructions").Delete 
Sheets("Dropdowns").Delete 
Sheets("Dropdowns2").Delete 
Sheets("Range Reference").Delete 
Sheets("All Fields").Delete 
Sheets("ExistingData").Delete 
Application.DisplayAlerts=TRUE 
End Sub 

Answer 2

考虑这一点。

Sub Example() 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String, Fnum As Long 
    Dim mybook As Workbook 
    Dim CalcMode As Long 
    Dim sh As Worksheet 
    Dim ErrorYes As Boolean 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    'Add a slash at the end if the user forget it 
    If Right(MyPath, 1) <> "\" Then 
     MyPath = MyPath & "\" 
    End If 

    'If there are no Excel files in the folder exit the sub 
    FilesInPath = Dir(MyPath & "*.xl*") 
    If FilesInPath = "" Then 
     MsgBox "No files found" 
     Exit Sub 
    End If 

    'Fill the array(myFiles)with the list of Excel files in the folder 
    Fnum = 0 
    Do While FilesInPath <> "" 
     Fnum = Fnum + 1 
     ReDim Preserve MyFiles(1 To Fnum) 
     MyFiles(Fnum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'Change ScreenUpdating, Calculation and EnableEvents 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Loop through all files in the array(myFiles) 
    If Fnum > 0 Then 
     For Fnum = LBound(MyFiles) To UBound(MyFiles) 
      Set mybook = Nothing 
      On Error Resume Next 
      Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 


       'Change cell value(s) in one worksheet in mybook 
       On Error Resume Next 
       With mybook.Worksheets(1) 
        If .ProtectContents = False Then 
         .Range("A1").Value = "My New Header" 
        Else 
         ErrorYes = True 
        End If 
       End With 


       If Err.Number > 0 Then 
        ErrorYes = True 
        Err.Clear 
        'Close mybook without saving 
        mybook.Close savechanges:=False 
       Else 
        'Save and close mybook 
        mybook.Close savechanges:=True 
       End If 
       On Error GoTo 0 
      Else 
       'Not possible to open the workbook 
       ErrorYes = True 
      End If 

     Next Fnum 
    End If 

    If ErrorYes = True Then 
     MsgBox "There are problems in one or more files, possible problem:" _ 
      & vbNewLine & "protected workbook/sheet or a sheet/range that not exist" 
    End If 

    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

来源：https://www.rondebruin.nl/win/s3/win010.htm