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
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.