複数のExcelブックをVBAで解析する

Question

私はVBAで優れているわけではありません（私の典型的な使用例は、マクロを記録し、何も作成しないでVBAをクリーニングして変更することです）。私はKutoolsを使用してすべてを統合する前に〜300のワークブックをスリム化しようとしています。

私は統合を可能にするために、これらのブックの不要な部分を削除するために少しの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 

私は私が私の目的に適応しようとしたのです複数のワークブック間で所定のタスクを実行しますStackOverflowの上でコードの優れたビットが見つかりました：

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 

オリジナルのスレッドはここで見つけることができます：私は「「ここにあなたの仕事をする」と「.Worksheets（1）.Range（ 『A1』）値に私のコードを挿入しようとした Run same excel macro on multiple excel files

= "Hello World！" "元のvba、しかし成功していない。同様に、成功していない複数のExcelワークブックにまたがってマクロを実行するために、私の解析コードをいくつかの他のソリューションに挿入してみました。

呼び出すブックが開いて保存されていますが、実際にコードが実行しようとしている実際の作業は（エラーを記録せずに）起こっていません。私が挿入しているコードの一部が、私が知っているよりももっと知り合っている人にとっては、とても分かりやすい方法で互換性がないと思われます。

誰でもヘルプ/ガイダンスを提供できますか？私は実際には、 "C：\ Temp \ Workbooks"にある300個のワークブックでオリジナルの "PrepWorkbook" VBAを実行する方法についてのコードや指示が必要です

Answer 1

コードの最初のセクションでは、 THISWORKBOOKを使用してください。THISWORKBOOKは、実行されている場所に隔離されています。コメントの中で 'PG'の行の下に使用してください。私はまた、あなたの2番目のマクロに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