How do I get errors only for the files that error out - vba

Question

At my company we need to convert a lot of text files each month to excel and some of the columns we need to change the data types of the columns. They used to convert all of them manually which was very time consuming. I created an access program that they can do it in much easier. They just hit a button and it transfers them, with a running list of all the files converted. Some of the files will change here and there, so when running the program I have another list that is supposed to show all the files that cause an error. Unfortunately, what it does, at the moment, once it receives the error from one file - every file after that also says there is an error. So if there are 100 files witch file 5 and 25 as errors, it would still show all files from 5 to 100 are errors. Here is the code I am using:
Public Sub ImportTextFile(ByVal xl As Excel.Application, ByVal strFileName As String, ByVal iNumOfCols As Integer, Optional aDataTypes As Variant = Nothing)
On Error GoTo Sub_Err
Dim sPathAndFile As String: sPathAndFile = cPath & strFileName
Dim wb As Workbook: Set wb = xl.Workbooks.Add
Dim ws As Worksheet: Set ws = wb.Sheets(1)
With ws.QueryTables.Add(Connection:="TEXT;" & sPathAndFile & ".txt", Destination:=ws.Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = GetColumnDataTypes(iNumOfCols, aDataTypes)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Call SaveFile(wb, sPathAndFile)
Forms("Dashboard").lbCompleted.AddItem strFileName
Forms("Dashboard").lbCompleted.Selected(Forms("Dashboard").lbCompleted.ListCount - 1) = True
Sub_End:
Set wb = Nothing
Set ws = Nothing
Err.Clear
Exit Sub
Sub_Err:
'MsgBox Err.Description
Forms("Dashboard").lbError.AddItem strFileName
Resume Sub_End
End Sub
and then each file calls back like this:
Call ImportTextFile(xl, "DGXC094P", 11)
Call ImportTextFile(xl, "DGAC081", 18, Array(, , , , , , , , , , , , , , , , , , 2))
I tried clearing the error but it doesn't clear. What am I doing wrong? How can I get it to show only the files that have errors?

Answer 1

Concerning the Sub to import the Textfile: Make it a function. Then you are able to give a callback if there was an error or not. Like this:
Public Function ImportTextFile(ByVal xl As Excel.Application, ByVal strFileName As String, ByVal iNumOfCols As Integer, Optional aDataTypes As Variant = Nothing) as string
On Error GoTo ErrorHandling
Dim sPathAndFile As String: sPathAndFile = cPath & strFileName
Dim wb As Workbook: Set wb = xl.Workbooks.Add
Dim ws As Worksheet: Set ws = wb.Sheets(1)
With ws.QueryTables.Add(Connection:="TEXT;" & sPathAndFile & ".txt", Destination:=ws.Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = GetColumnDataTypes(iNumOfCols, aDataTypes)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Call SaveFile(wb, sPathAndFile)
Forms("Dashboard").lbCompleted.AddItem strFileName
Forms("Dashboard").lbCompleted.Selected(Forms("Dashboard").lbCompleted.ListCount - 1) = True
Set wb = Nothing
Set ws = Nothing
ImportTextFile = "ok"
Exit Function
ErrorHandling:
Set wb = Nothing
Set ws = Nothing
ImportTextFile = Err.Description
End Function
Your procedure to call the function should look like this:
Dim ImportResult as string
ImportResult = ImportTextFile(xl, "DGAC081", 18, Array(, , , , , , , , , , , , , , , , , , 2))
'Case Import Error
If ImportResult <> "ok" then
MsgBox (ImportResult)
Forms("Dashboard").lbError.AddItem strFileName
end if
'Case Import OK
If ImportResult = "ok" then
'What you want
end if
When using a function instead of a sub you will be able to treat each import individually.