Thank you abousetta and Izandol for your responses and suggestions. I apologize for not responding sooner, had problems in accessing this site from work.

Anyway, in using your suggestions, it has helped alot and now I am dealing with one issue. As the program matches the policy number against the ADOBC record, in column K, it should write either "Yes" (that it contains the Block Code "1011") or "No" (that it does not). It works for the first row (row 7) but it does not continue after that. I am wondering what I have done wrong.

Below are the codes that I am using along with my little "tweaks":


Sub CBreader()

    'Establish connection and record set with CRMDB
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    
    
    Set cnn = New ADODB.Connection
    Set rst = New ADODB.Recordset
    
    'Dim strSQL As String
    
    'Declare field variables
    Dim GetItem As String
    Dim FPolicy As Range
    Dim PN As Range
    Dim FBlock As String
    Dim FMsg As String
    Dim wb As Workbook
    Dim WS As Worksheet
    Dim RCount As Long
    Dim BCount As Integer
    Dim counter1 As Integer
    Dim MPolicy As String
    Dim STPolicy As String
    
       
    counter1 = 7
    BCount = 7
    
    Set wb = ThisWorkbook
    
    'Activate Workbook & Worksheet
    Set WS = wb.Worksheets("EF")
    WS.Activate
       
    'Open the ODBC Connection using this statement
    
    With WS
        
        RCount = .Range("D" & .Rows.Count).End(xlUp).Row
        Set FPolicy = .Range("D7:D" & RCount)
             
        cnn.Open "CRMDB", "[Username]", "[Password]"
        rst.ActiveConnection = cnn
        rst.CursorLocation = adUseServer
        
       
        STPolicy = CriteriaFromRange(FPolicy)
        
        rst.Source = "Select * FROM u_CloseBlock WHERE [u_CloseBlock].[Policy] in (" & STPolicy & ")"
        rst.Open
    
                      
        Do While Not rst.EOF
        
        For Each PN In ActiveSheet.Range("D7:D" & BCount)
            If BCount = 7 Then
                MPolicy = PN.Value
            Else
                MPolicy = PN.Offset(1, 0).Value
            End If
        
                MPolicy = rst.Fields("Policy").Value
               'MPolicy = rst.Fields("Policy")
                FBlock = rst.Fields("Block_No")
              
             With PN
                If FBlock = "1011" Then
                    FMsg = "Yes"
                    .Range("K", counter1).Value = FMsg
                    '.Offset(BCount, 7).Value = FMsg
                ElseIf IsNull(FBlock) Then
                    FMsg = "No"
                    Range("K", counter1).Value = FMsg
                    '.Offset(BCount, 7).Value = FMsg
                End If
            End With
                        
                counter1 = counter1 + 1
                BCount = BCount + 1
        
        Next PN
        rst.MoveNext
        Loop
      
           
    End With
       
    'Close everything and set the references to nothing
    rst.Close
    Set rst = Nothing
    cnn.Close
    Set cnn = Nothing
    
     
 End Sub
 
 Function CriteriaFromRange(rgCriteria As Range) As String
 
 Dim Cell As Range
 Dim sTemp As String
 
 For Each Cell In rgCriteria.Cells
    If Len(Cell.Value) > 0 And sTemp = " " Then
        sTemp = "'" & Cell.Value & "'"
    ElseIf Len(Cell.Value) > 0 And sTemp <> " " Then
        sTemp = sTemp & ",'" & Cell.Value & "'"
    End If
 Next Cell
 
 'Now strip off leading comma
 CriteriaFromRange = Mid$(sTemp, 2)
 End Function
 
 Function EscapeQuotes(sInput As String) As String
    EscapeQuotes = Replace(sInput, "'", "'")

 End Function
Any suggestions would be welcomed. Thank you.