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

晚上好，

我设法识别问题，因为有些电子表格没有数据产生，因为它无法继续下一张表格。

我现在已经通过添加额外的命令来解决此问题，以继续发生错误。

感谢您的所有意见和反馈。

为什么我的VBA不工作？

1 个答案: