VBAが動作しないのはなぜですか？

Question

私は、フォルダ内のすべてのファイルをループし、列データを別々のタブに分割するVBAコードを実行するコードを取得しようとしています。代わりに、ファイルを開き、何も実行できません。

Sub SPLIT_WORKBOOK() 

    Dim folderPath As String 

    folderPath = ThisWorkbook.Path & "\" 

    Filename = Dir(folderPath & "*.xlsx") 

    Do While Filename <> "" 
     Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True) 

     For Each sh In wb.Sheets 

      Dim lr As Long 
      Dim ws As Worksheet 
      Dim vcol, i As Integer 
      Dim iCol As Long 
      Dim myarr As Variant 
      Dim title As String 
      Dim titlerow As Integer 

      'code to seletct row 
      ActiveWorkbook.Activate 
      'code above 

      vcol = 4 
      Set ws = Sheets("Sheet1") 
      ActiveSheet.Select 
      lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
      title = "A1:L5" 
      titlerow = ws.Range(title).Cells(1).Row 
      iCol = ws.Columns.Count 
      ws.Cells(1, iCol) = "SEL" 

      For i = 3 To lr 
       On Error Resume Next 
       If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(iCol), 0) = 0 Then 
        ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
       End If 
      Next 

      myarr = Application.WorksheetFunction.Transpose(ws.Columns(iCol).SpecialCells(xlCellTypeConstants)) 
      ws.Columns(iCol).Clear 

      For i = 2 To UBound(myarr) 

       ' CODE THATS BUGGING I THINK 

       ws.Range(title).AutoFilter Field:=vcol, Criteria1:=Array(_ 
       "Category", "DST", "Store"), Operator:=xlFilterValues 

       If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
       Else 
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
       End If 

       ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
       Sheets(myarr(i) & "").Columns.AutoFit 
      Next 

      ws.AutoFilterMode = False 
      ws.Activate 

      'SECOND ZACK CODE 

      vcol = 4 
      Set ws = Sheets("Sheet1") 
      lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
      title = "A1:L5" 
      titlerow = ws.Range(title).Cells(1).Row 
      iCol = ws.Columns.Count 
      ws.Cells(1, iCol) = "DST" 

      For i = 3 To lr 
       On Error Resume Next 
       If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(iCol), 0) = 0 Then 
        ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
       End If 
      Next 

      myarr = Application.WorksheetFunction.Transpose(ws.Columns(iCol).SpecialCells(xlCellTypeConstants)) 
      ws.Columns(iCol).Clear 

      For i = 2 To UBound(myarr) 

       'CODE THATS BUGGING I THINK 

       ws.Range(title).AutoFilter Field:=vcol, Criteria1:=Array(_ 
       "Category", "SEL", "Store"), Operator:=xlFilterValues 

       If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
       Else 
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
       End If 

       ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
       Sheets(myarr(i) & "").Columns.AutoFit 
      Next 

      ws.AutoFilterMode = False 
      ws.Activate 


      'DELETE NON REQUIRED WORKSHEETS 

      Application.DisplayAlerts = False 
      Sheets(Array("Store", "Category")).Select 
      ActiveWindow.SelectedSheets.Delete 
      Application.DisplayAlerts = True 

     Next 

     wb.Close False 
     Filename = Dir 
     Set wb = Nothing 
    Loop 

End Sub 

Answer 1

こんばんは、

は、私はいくつかのスプレッドシートは、これはそれが次のシート上に継続することができなかったループれた際に発生するデータを全く持っていないような問題を識別するために管理しました。

エラーが発生した場合は、続行するコマンドを追加して問題を解決しました。

ご意見ありがとうございました。