Excel stop working when i run macro

[Muhammad Shakeel Ishaq]

Hello Respected Friends,

I am running this macro for last one year and more. Now i am facing problem that, when i run this specific macro, my excel stop working. Could you please help me. (error screen shot is attached)

Option Explicit

Sub ThisGuySeemsToBeLazierThanButObUtHc()
    '
    ' constants
    '  access file type
    Const ksDBPattern = "*.mdb"
    '  folder path
    '   \\zzz... full path
    '   x:\zzz... full path
    '   zzz... relative path
    '   "" actual path
    Const ksPath = "C:\Users\hp\Desktop\Data Loader\Jahanian MIS December 2014"
    '  access table list
    '   x,zzzz[,zzzz]
    Const ksTableList = "X,Ledger"
    Const ksSeparator = ","
    '  others
    Const ksColon = ":"
    Const ksBackSlash = "\"
    Const ksDash = "-"
    '
    ' declarations
    Dim cn As ADODB.Connection, rsT As ADODB.Recordset, rs As ADODB.Recordset
    Dim vTable As Variant
    Dim sPath As String, sTable As String
    Dim I As Long, J As Long, A As String
    '
    ' start
    '  path
    If InStr(ksPath, ksBackSlash & ksBackSlash) > 0 Or InStr(ksPath, ksColon) > 0 Then
        ' full
        sPath = ksPath
    Else
        ' relative or actual
        sPath = ThisWorkbook.Path
        If Len(ksPath) > 0 Then sPath = sPath & Application.PathSeparator
        sPath = sPath & ksPath
    End If
    sPath = sPath & Application.PathSeparator
    '  tables
    vTable = Split(ksTableList, ksSeparator)
    '  workbook
    With ActiveWorkbook
        ' remove worksheets
        Application.DisplayAlerts = False
        For I = .Worksheets.Count To 2 Step -1
            .Worksheets(I).Delete
        Next I
        Application.DisplayAlerts = True
        ' create worksheets
        For I = 1 To UBound(vTable)
            .Worksheets.Add , .Worksheets(I)
            .Worksheets(I + 1).Name = vTable(I)
        Next I
    End With
    '
    ' process
    A = Dir(sPath & ksDBPattern)
    I = 0
    Do Until A = ""
        ' new db
        I = I + 1
        ' open db
        Set cn = New ADODB.Connection
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & sPath & A & ";" & _
            "Persist Security Info=False;"
        ' open rs tables
        Set rsT = cn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))
        Do While Not rsT.EOF
            ' table
            sTable = rsT!TABLE_NAME
            For J = 1 To UBound(vTable)
                If sTable = CStr(vTable(J)) Then Exit For
            Next J
            If J <= UBound(vTable) Then
                ' open rs each table
                Set rs = New ADODB.Recordset
                rs.Open "select * from " & sTable, cn
                ' ws
                With Worksheets(sTable)
                    ' get titles, if 1st time
                    If [A1].Value = "" Then
                        For J = 0 To rs.Fields.Count - 1
                            .Cells(1, J + 1).Value = rs.Fields(J).Name
                        Next J
                    End If
                    ' get data
                    J = .[A1].End(xlDown).End(xlDown).End(xlUp).Row + 1
                    .Cells(J, 1).CopyFromRecordset rs
                End With
                ' close rs
                rs.Close
            End If
            rsT.MoveNext
        Loop
        ' close rstables
        rsT.Close
        cn.Close
        ' cycle
        A = Dir()
    Loop
    '
    ' end
    Set rs = Nothing
    Set rsT = Nothing
    Set cn = Nothing
    Beep
    '
End Sub

 

[Deepak]

Pls always follow forum rules to tag the code.

 

[Deepak]

Hi,

Neither any error screen shot nor problematic workbook found!!

 

[Muhammad Shakeel Ishaq]

Sorry Deepak and thanks issue resolved. Excel was got corrupted.