VBA code is running but unable to generate excel output files

Question

My VBA code is running but unable to generate excel output files. Can someone help me please to debug the code below. Thank you.

Sub Bill()
    
    Dim aFile As String
    ' Define the output folder
    aFile = "C:\TEST\OUTPUT FILES\*.*"
    
    If Len(Dir$(aFile)) > 0 Then
        ' If the output folder is not empty, delete ALL files from this folder
        Kill aFile
    End If
    
    Dim i As Integer, j As Integer 'i is index in Generate Files sheet, j is index in Query Output sheet
    Dim ti As Integer, tj As Integer
    Dim criteria() As String
    Dim bc As String, bm As String
    Dim p As Integer, k As String
    Dim newbook As Workbook

    ' Sheet4 is the "Generate Files"
    ti = ThisWorkbook.Sheets("Generate Files").UsedRange.Rows.Count 'ti is total row count in Generate Files sheet
    tj = ThisWorkbook.Sheets("Query Output").UsedRange.Rows.Count 'tj is total row count in Query Output sheet
    
    ' Traverse all rows in Sheet4("Generate Files")
    For i = ti To 2 Step -1
        ' Start from the E3 cell
        k = ThisWorkbook.Sheets("Generate Files").Cells(i, 4).Value ' Column D is the 4th column
        
        ' Query the criteria
        criteria = Split(ThisWorkbook.Sheets("Generate Files").Cells(i, 1).Value, ":")
        If UBound(criteria) > 0 Then
            ' Split the criteria
            bc = criteria(0)
            bm = criteria(1)
        Else
            ' The criteria only contain one char
            bc = criteria(0)
            bm = ""
        End If
        
        ' Add header names
        Set newbook = Workbooks.Add
        With newbook.Worksheets(1)
            .Cells(1, 1).Value = "Company"
            .Cells(1, 2).Value = "Cost Center"
            .Cells(1, 3).Value = "Unit Name"
            .Cells(1, 4).Value = "Username"
            .Cells(1, 5).Value = "EmpNo"
            .Cells(1, 6).Value = "Access Type"
            .Cells(1, 7).Value = "REPLY"
        End With
        
        p = 2 ' Declared variable p as 2
        If bm <> "" Then
            ' Traverse all rows in the Sheet1("Query Output")
            For j = 2 To tj
                If ThisWorkbook.Sheets("Query Output").Cells(j, 4).Value = bc Then
                    ' If cells in the column A of "Generate Files" matched in the column 4 of the "Query Output" sheet, then copy entire row from Sheet1(Query Output) to new workbook
                    ThisWorkbook.Sheets("Query Output").Cells(j, 1).EntireRow.Copy Destination:=newbook.Worksheets(1).Range("A" & p)
                    ' Clean the copied row
                    ThisWorkbook.Sheets("Query Output").Rows(j).ClearContents
                    ' Increase the row index by 1
                    p = p + 1
                End If
            Next j
        Else
            ' Traverse all rows in the Sheet1("Query Output")
            For j = 2 To tj
                If ThisWorkbook.Sheets("Query Output").Cells(j, 4).Value = bc Then
                    ' If cells in the column A of "Generate Files" matched in the column 4 of the "Query Output" sheet, then copy entire row from Sheet1(Query Output) to new workbook
                    ThisWorkbook.Sheets("Query Output").Cells(j, 1).EntireRow.Copy Destination:=newbook.Worksheets(1).Range("A" & p)
                    ' Increase the row index by 1
                    p = p + 1
                End If
            Next j
        End If
        
        If IsEmpty(newbook.Worksheets(1).Cells(2, 1).Value) Then
            ' If the data in the column A of the "Generate Files" is not found in the Query Output column 4, don't save the file
            newbook.Close SaveChanges:=False
        Else
            ' Save the target workbook
            newbook.SaveAs Filename:="C:\TEST\OUTPUT FILES\" & k & ".xlsx"
            newbook.Close
        End If
        
    Next i ' Loop
    
    MsgBox "File Creation Complete" ' Display a message box once the file creation is complete

End Sub

I was trying to debug the code multiple times but still not generating an excel output files on the defined directory. Appreciate if you could help me on my problem. Thanks.

Answer 1

Your code could be simplified a little - for example check there's at least one match on bc before adding a new workbook and running the inner loop.

Sub Bill()
    
    Const ROOT_FOLDER As String = "C:\TEST\OUTPUT FILES\"
    Dim i As Long, j As Long, ti As Long, tj As Long
    Dim criteria() As String
    Dim bc As String, hasBm As Boolean, vA
    Dim p As Integer, aFile As String, k As String
    Dim wsGen As Worksheet, wsQ As Worksheet, wsNew As Worksheet
    
    aFile = ROOT_FOLDER & "*.*"
    If Len(Dir$(aFile, vbNormal)) > 0 Then Kill aFile 'delete any files from this folder
        
    Set wsGen = ThisWorkbook.Worksheets("Generate Files")
    Set wsQ = ThisWorkbook.Worksheets("Query Output")
    
    ti = wsGen.UsedRange.Rows.Count 'ti is total row count in Generate Files sheet
    tj = wsQ.UsedRange.Rows.Count 'tj is total row count in Query Output sheet
    
    For i = ti To 2 Step -1 ' Traverse all rows in "Generate Files"
        
        vA = Trim(wsGen.Cells(i, 1).Value) 'trim ColA value
        If Len(vA) > 0 Then
            criteria = Split(vA, ":")
            bc = criteria(0)
            hasBm = UBound(criteria) > 0 'any BM value?
            
            'any data to transfer? Check for at least one match first...
            If Not IsError(Application.Match(bc, wsQ.Columns("D"), 0)) Then
                Set wsNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'new workbook with one sheet
                wsNew.Range("A1").Resize(1, 7).Value = Array("Company", "Cost Center", _
                                 "Unit Name", "Username", "EmpNo", "Access Type", "REPLY")
                
                p = 2
                For j = 2 To tj ' Traverse all rows in the "Query Output"
                    If wsQ.Cells(j, 4).Value = bc Then 'bc match on ColD?
                        With wsQ.Rows(j)
                            .Copy Destination:=wsNew.Range("A" & p)
                            If hasBm > 0 Then .ClearContents     ' Clean the copied row ?
                        End With
                        p = p + 1
                    End If
                Next j
                k = wsGen.Cells(i, "D").Value 'output file name
                wsNew.Parent.SaveAs Filename:=ROOT_FOLDER & k & ".xlsx"
                wsNew.Parent.Close
            End If   'any row(s) to transfer
        End If       'any value in ColA
    Next i
    
    MsgBox "File Creation Complete" ' Display a message box once the file creation is complete

End Sub