为什么我的 VBA 不起作用？

Question

I am trying to get the code to loop through all files in the folder and perform the VBA code which is to split column data into separate tabs. Instead, it opens the file and then fails to perform anything.

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

Good evening,

I managed to identify the issue as some spreadsheets had no data produced when this was looped it failed to continue onto the next sheet.

I have now resolved the issue by adding an additional command to continue on error.

Thank you for all your input and feedback.