Clean up code that transfers data from DB2 Server to Excel

Question

The code below is functional and works as expected, but I imagine there is a better way to test for the error that I am testing for .

The scenario is that data is transferred between two different servers throughout the year, so I built in an error handler that checks to see if the connection to that server is valid; if the connection is not valid then it goes to an Error Handler. I am seeking review of this code to streamline it and hopefully process it more efficiently.

CODE:

Option Explicit
Sub CIFIncoming()
    Dim adoConn As New ADODB.Connection
    Dim cfRS As New ADODB.Recordset
    Dim Name As String, Address1 As String, Address2 As String
    Dim City As String, State As String, Zip As String
    Dim HomePhone As String, CellPhone As String
    Dim BSA As String
    Dim strConn As String
    Dim CIFstr As String, CIF As String

    On Error GoTo ErrHandler

'\\\\BEGIN DATABASE INFORMATION GRAB////
'   1.  Sets the Connection String to the Data Base
'   2.  Opens the connection to the database
'   3.  Sets the SQL String to get the fields from the Data Base
'   4.  Defines the CIF Number to use in the SQL String
'   5.  Opens the Recordset
'   6.  Checks to see where the cursor in the DataBase is and runs the code based on that conditon
'       BOF = Begining of File
'       EOF = End of File

    strConn = REDACTED

    adoConn.Open strConn

    CIF = UCase(Sheet1.Range("B103").Text)

    CIFstr = "SELECT " & _
             "cfna1, cfna2, cfna3, cfcity, cfstat, LEFT(cfzip, 5), cfhpho, cfcel1, cfudsc6 " & _
             "FROM cncttp08.jhadat842.cfmast cfmast " & _
             "WHERE cfcif# = '" & CIF & "'"

    cfRS.Open CIFstr, adoConn

    If Not (cfRS.BOF And cfRS.EOF) Then

'\\\\END DATABASE INFORMATION GRAB////

'\\\\BEGIN WORKSHEET INFORMATION PLACEMENT////
'   1.  Assigns each field from the Database to a variable
'   2.  Moves data from Database to specific cells

        Name = Trim(cfRS(0))     'cfna1
        Address1 = Trim(cfRS(1)) 'cfna2
        Address2 = cfRS(2)       'cfna3
        City = Trim(cfRS(3))     'cfcity
        State = Trim(cfRS(4))    'cfstat
        Zip = cfRS(5)            'cfzip
        HomePhone = cfRS(6)      'cfhpho
        CellPhone = cfRS(7)      'cfcel1
        BSA = cfRS(8)            'cfudsc6

        With Sheet1
            .Range("B104") = Name
            .Range("B105") = Address1
            .Range("B106") = Address2
            .Range("B107") = City & ", " & State & " " & Zip
        End With

    End If

    If Sheet1.Range("B103") = vbNullString Then
        With Sheet1
            .Range("B104") = vbNullString
            .Range("B105") = vbNullString
            .Range("B106") = vbNullString
            .Range("B107") = vbNullString
        End With
    End If

'\\\\END WORKSHEET INFORMATION PLACEMENT////

'\\\\BEGIN FINAL DATABASE OPERATIONS////
'   1.  Closes connection to Database
'   2.  Sets the Recordset from the Database to Nothing
'   3.  Exits sub when there are no errors

    cfRS.Close
    Set cfRS = Nothing
    Exit Sub
'\\\\END FINAL DATABASE OPERATIONS

ErrHandler:
    If Err.Number = -2147467259 Then GoTo Branson

Branson:
    CIF = UCase(Sheet1.Range("B103").Text)

    CIFstr = "SELECT " & _
             "cfna1, cfna2, cfna3, cfcity, cfstat, LEFT(cfzip, 5), cfhpho, cfcel1, cfudsc6 " & _
             "FROM bhschlp8.jhadat842.cfmast cfmast " & _
             "WHERE cfcif# = '" & CIF & "'"

    cfRS.Open CIFstr, adoConn

    If Not (cfRS.BOF And cfRS.EOF) Then

'\\\\END DATABASE INFORMATION GRAB////

'\\\\BEGIN WORKSHEET INFORMATION PLACEMENT////
'   1.  Assigns each field from the Database to a variable
'   2.  Moves data from Database to specific cells

        Name = Trim(cfRS(0))     'cfna1
        Address1 = Trim(cfRS(1)) 'cfna2
        Address2 = cfRS(2)       'cfna3
        City = Trim(cfRS(3))     'cfcity
        State = Trim(cfRS(4))    'cfstat
        Zip = cfRS(5)            'cfzip
        HomePhone = cfRS(6)      'cfhpho
        CellPhone = cfRS(7)      'cfcel1
        BSA = cfRS(8)            'cfudsc6

        With Sheet1
            .Range("B104") = Name
            .Range("B105") = Address1
            .Range("B106") = Address2
            .Range("B107") = City & ", " & State & " " & Zip
        End With

    End If

    If Sheet1.Range("B103") = vbNullString Then
        With Sheet1
            .Range("B104") = vbNullString
            .Range("B105") = vbNullString
            .Range("B106") = vbNullString
            .Range("B107") = vbNullString
        End With
    End If

'\\\\END WORKSHEET INFORMATION PLACEMENT////

'\\\\BEGIN FINAL DATABASE OPERATIONS////
'   1.  Closes connection to Database
'   2.  Sets the Recordset from the Database to Nothing
'   3.  Exits sub when there are no errors

    cfRS.Close
    Set cfRS = Nothing
    Exit Sub
'\\\\END FINAL DATABASE OPERATIONS

End Sub

Answer 1

It is far easier to write, debug and modify smaller chunks of code that perform 1 or 2 operations. For this reason, the code should be separated into multiple subs and functions. I also recommend taking advantage of Field Aliases to give your Fields more meaningful names.

Refactored Code

Option Explicit
Const REDACTED = "<Connection String>"

Private Type DBGrabRecord
    Name As String
    Address1 As String
    Address2 As String
    City As String
    State As String
    Zip As String
    HomePhone As String
    CellPhone As String
    BSA As String
    TableName As String
    ErrNumber As Long
End Type


Sub CIFIncoming()
    Const bhschlp8 As String = "bhschlp8.jhadat842.cfmast cfmast"
    Const cncttp08 As String = "cncttp08.jhadat842.cfmast cfmast"
    Const ConnectionError As Long = -2147467259

    Dim CIF As String
    Dim tDBGrabRecord As DBGrabRecord

    CIF = Sheet1.Range("B103").Text

    If Not CIF = vbNullString Then
        tDBGrabRecord = getDBGrabTestRecord(bhschlp8, CIF)
        If tDBGrabRecord.ErrNumber = ConnectionError Then tDBGrabRecord = getDBGrabTestRecord(cncttp08, CIF)
    End If

    With Sheet1
        .Range("B104") = tDBGrabRecord.Name
        .Range("B105") = tDBGrabRecord.Address1
        .Range("B106") = tDBGrabRecord.Address2
        .Range("B107") = tDBGrabRecord.City & ", " & tDBGrabRecord.State & " " & tDBGrabRecord.Zip
    End With

    Debug.Print "Table Name: "; tDBGrabRecord.TableName

End Sub

Private Function getDBGrabTestRecord(ByVal TableName As String, ByVal CIF As String) As DBGrabRecord
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim SQL As String
    Dim tDBGrabRecord As DBGrabRecord

    On Error Resume Next

    conn.Open REDACTED

    SQL = getDBGrabSQL(TableName, CIF)

    rs.Open CIFstr, conn

    If Not (rs.BOF And rs.EOF) Then
        With tDBGrabRecord
            .Name = Trim(rs.Fields("Name").Value)
            .Address1 = Trim(rs.Fields("Address1").Value)
            .Address2 = Trim(rs.Fields("Address2").Value)
            .City = Trim(rs.Fields("City").Value)
            .State = Trim(rs.Fields("State").Value)
            .Zip = Trim(rs.Fields("Zip").Value)
            .HomePhone = Trim(rs.Fields("HomePhone").Value)
            .CellPhone = Trim(rs.Fields("CellPhone").Value)
            .BSA = Trim(rs.Fields("BSA").Value)
            .TableName = TableName
        End With
    End If

    rs.Close
    conn.Close

    tDBGrabRecord.ErrNumber = Err.Number

    getDBGrabTestRecord = tDBGrabRecord
End Function

Private Function getDBGrabSQL(ByVal TableName As String, ByVal CIF As String) As String
    Dim SelectClause As String
    Dim FromClause As String
    Dim WhereClause As String

    SelectClause = "SELECT cfna1 AS Name, cfna2 AS Address1, cfna3 AS Address2, cfcity AS City, cfstat AS State, LEFT(cfzip, 5) AS Zip, cfhpho AS HomePhone, cfcel1 AS CellPhone, cfudsc6 AS BSA"
    FromClause = "FROM " & TableName
    WhereClause = "WHERE cfcif# = '" & UCase(CIF) & "'"

    getDBGrabSQL = SelectClause & vbNewLine & FromClause & vbNewLine & WhereClause
End Function