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

• Zack E: Thank you. I still have a lot to learn about writing code in VBA, so I really appreciate this. I wont be able to test it out tonight, but I will tomorrow and if this all works I will accept this answer.
• TinMan: @ZackE In truth, although my code is clean, my review is pretty crappy. You should probably wait and accept a better review.
• TinMan: @ZackE This sieries will help you: Excel VBA Introduction Part 1 - Getting Started in the VB Editor
• Zack E: I actually love that series. I will need to keep watching more of them though. Thanks again!
• Zack E: This works perfectly and I am able to follow and understand what the code is doing. I did have to make one change though; I changed rs.Open CIFstr, conn to rs.Open SQL, conn