DevOps, CI/CD and Automation

Hi,
I am an Oracle Developer and i have no idea why this error is orrcuing in one of the VBA macro.

I am currently working on Windows XP Pro SP2 with MS Office 2003. I have this macro which used to work very fine before we updated to current system. Now it is giving an error not always but out of 5 time about 3 times. It always starts running but sometime in betweeb it fails and throws this error

Macro
------------------

Sub compare_wb()


On Error GoTo handle_error

PathName$ = "C:\test\"
ChDir PathName$

Dim cur_date As Variant
cur_date = Format(Date, "yyyymmdd")

Do
   Dim UserId As String
      UserId = Application.InputBox("Enter UserName ")

   Dim Passwd As String
      Passwd = Application.InputBox("Enter Password ")

   Dim Server As String
      Server = Application.InputBox("Enter Instance ")
   If UserId = "" Or Passwd = "" Or Server = "" Then
      MsgBox "One of the value is not entered"
      If MsgBox("Do you want to continue to try again?", vbQuestion + vbYesNo, "Difference of Carrier Keys ") = vbNo Then
         Exit Sub
      End If
   Else
      Exit Do
   End If
Loop

Dim NewWb As Variant, InpWb  As Variant

Dim InpWs As Worksheet, NewWs As Worksheet

InpWb = Application.GetOpenFilename("Excel-file (*.xls*), *.xls*", _
1, "Select the New Spreadsheet", , False)
If InpWb = False Then
   MsgBox "You cancelled"
Else
   Workbooks.Open InpWb
   Set InpWs = Workbooks(ActiveWorkbook.Name).Sheets("sheet1")
End If

'******************

If InpWb <> False Then 'Do not run if spreadsheet is not selected

InpWs.Activate


mylastrow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row


' Create a new worksheet to add the missing Group Numbers
Workbooks.Add
Set NewWs = Workbooks(ActiveWorkbook.Name).Sheets("sheet1")

NewWs.Activate
ActiveSheet.Cells(1, 1).Select
   
InpWs.Activate
For x = 1 To mylastrow
   hmo = Trim(Sheets("Sheet1").Range("B4").Offset(x, 0).Value)
   grp_num = Trim(Sheets("Sheet1").Range("C4").Offset(x, 0).Value)
   plan_sponsor = Trim(Sheets("Sheet1").Range("D4").Offset(x, 0).Value)
   cust_name = Sheets("Sheet1").Range("E4").Offset(x, 0).Value

   If grp_num <> "" Then
      If hmo <> "HMO" Then
         If Left(grp_num, 1) <> "3" Then
            grp_num = "0" & grp_num
         End If
      End If

      NewWs.Activate
      ActiveCell.Offset(1, 0).Select
      vConn = "ODBC;DSN=" & Server & ""
      vConn = vConn & ";UID=" & UserId
      vConn = vConn & ";PWD=" & Passwd
      vConn = vConn & ";SERVER=" & Server
      
      vSql = "select count(group_number) from elig_group"
      vSql = vSql & " where group_number like " & "'" & grp_num & "%'"
      vSql = vSql & " and carrier_key in (select carrier_key from elig_carrier where mod_nabp_provider = " & "'" & 1014202 & "'" & " )"
      vSql = vSql & " and carrier_key in (select carrier_key from elig_carrier_plan_sponsor where plan_sponsor_id = " & "'" & plan_sponsor & "'" & ")"

      With ActiveSheet.QueryTables.Add( _
         Connection:=vConn, _
         Destination:=ActiveCell, _
         Sql:=vSql)

         .Name = "Query from Oracle Database"
         .FieldNames = False
         .RowNumbers = False
         .FillAdjacentFormulas = False
         .PreserveFormatting = True
         .RefreshOnFileOpen = False
         .BackgroundQuery = True
         .RefreshStyle = xlInsertDeleteCells
         .SavePassword = True
         .SaveData = True
         .AdjustColumnWidth = True
         .RefreshPeriod = 0
         .PreserveColumnInfo = True
         .Refresh BackgroundQuery:=False
      End With
     
      If ActiveCell.Value = "" Or ActiveCell.Value < 1 Then
         ActiveCell.Value = grp_num & "--" & cust_name
         Selection.Font.Bold = True
         Selection.Font.ColorIndex = 3
      Else
         ActiveCell.Value = ""
         'ActiveCell.Value = grp_num & "--" & cust_name
      End If
      InpWs.Activate
   End If
Next x

NewWs.Activate

Dim lastRow As Long
Dim currentRow As Long
Application.ScreenUpdating = False
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For currentRow = lastRow To 1 Step -1
   If Application.CountA(Rows(currentRow)) = 0 Then
      Rows(currentRow).Delete
   End If
Next currentRow

ActiveWorkbook.SaveAs Filename:=PathName$ + "NewGroups" + cur_date + ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False


End If ' if both the spreadsheet name selected then run macro

handle_error:
   If Err.Number = 9 Then
      MsgBox "Sheet name should be sheet1"
   Else
      MsgBox "An Error has occured" & vbCrLf & "Error Number " & Err.Number & Err.Description
   End If
   Exit Sub
End Sub


Error:
------------------------

Error -2147417848: The object invoked has disconnected from its clients

Can anyone suggest me how to over come this error in my VBA macro.
Thaks!

Sree

Edited by: user10401880 on Dec 12, 2008 8:42 AM