Question

我有以下代码，它们从关闭的文件中获取数据，并将结果输出到新的邮件对象中。数据文件有50万行，但如果查询在前10行中未找到结果，则返回空记录集：

    Sub MailingListQuery()

Application.ScreenUpdating = False
Dim c As Range
Dim d As Range
Dim Cn As ADODB.Connection
Dim Fichier As String
Dim NomFeuille As String, texte_SQL As String
Dim cmd As ADODB.Command
Dim Rst As ADODB.Recordset
'Dim CoPo as String
Dim CoPo() As String
Dim i As Integer
Dim Region As String
Dim lNumElements As Long

Dim MailAddress As Variant
ReDim MailAddress(0 To 0)
Region = ThisWorkbook.Worksheets("Menu").Range("H3").Value

'Closed WB location
Fichier = ThisWorkbook.Worksheets("Menu").Range("B7").Value

'Sh in closed WB
NomFeuille = "FMCSA_CENSUS1_2018Apr_chunk4"

If ThisWorkbook.Worksheets("Menu").Range("D3").Value = "Canada" Then
    With Worksheets(ThisWorkbook.Worksheets("Menu").Range("F3").Value).Range("F2:F" & Worksheets(ThisWorkbook.Worksheets("Menu").Range("F3").Value).Range("B65535").End(xlUp).Row)
        Set d = .Find(What:=Region, LookIn:=xlValues, MatchCase:=False, Lookat:=xlWhole)
        If Not d Is Nothing Then
            CoPo = Split(d.Offset(0, -3).Value, " ")
        End If
    End With
Else
    With Worksheets("Zip US").Range("F2:F" & Worksheets(ThisWorkbook.Worksheets("Menu").Range("F3").Value).Range("B65535").End(xlUp).Row)
        Set d = .Find(What:=Region, LookIn:=xlValues, MatchCase:=False, Lookat:=xlWhole)
        If Not d Is Nothing Then
            CoPo = Split(d.Offset(0, -3).Value, " ")
        End If
    End With
End If

'Debug
lNumElements = UBound(CoPo) - LBound(CoPo)
For i = 0 To lNumElements
    Worksheets("Debug").Range("A" & i + 1) = CoPo(i)
Next i
'------------------------------------------------------------------------------------------

Set Cn = New ADODB.Connection

'--- Connexion ---
With Cn
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
        & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    .Open
End With
'-----------------
lNumElements = UBound(CoPo) - LBound(CoPo)
For i = 0 To lNumElements
    'Request
    If ThisWorkbook.Worksheets("Menu").Range("B3") = "Tous" Then
        request_SQL = "SELECT [" & NomFeuille & "$].[MAILING_ZIP], [" & NomFeuille & "$].[EMAIL_ADDRESS] FROM [" & NomFeuille & "$]"
    Else
        request_SQL = "SELECT [" & NomFeuille & "$].[MAILING_ZIP], [" & NomFeuille & "$].[EMAIL_ADDRESS] FROM [" & NomFeuille & "$] WHERE [" & NomFeuille & "$].[MAILING_ZIP] LIKE ?"
    End If

    Set cmd = New ADODB.Command
    cmd.ActiveConnection = Cn
    cmd.CommandText = request_SQL
    cmd.Parameters.Append cmd.CreateParameter("@postalCode", adVarChar, adParamInput, 50)

    cmd.Parameters("@postalCode").Value = CoPo(i) + "%"

    Set Rst = cmd.Execute

    'Worksheets("Debug").Range("B1").CopyFromRecordset Rst 'Attention! vide le rst, le reste du code ne retournera rien, pour voir les records seulement

    Do While Not Rst.EOF
        If Not IsNull(Rst("EMAIL_ADDRESS").Value) Then
            If Not IsInArray(Rst("EMAIL_ADDRESS").Value, MailAddress) And ValidateEmailAddress(Rst("EMAIL_ADDRESS").Value) Then
                If IsEmpty(MailAddress) Then
                    MailAddress = Rst("EMAIL_ADDRESS").Value
                Else
                    ReDim Preserve MailAddress(1 To UBound(MailAddress) + 1)
                    MailAddress(UBound(MailAddress)) = Rst("EMAIL_ADDRESS").Value
                End If
            End If
        End If
        Rst.MoveNext
    Loop
Next i
'--- Outlook ---

If Not UBound(MailAddress) = 0 Then

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    On Error Resume Next

    With OutMail

        .BCC = Join(MailAddress, ", ")
        '.Subject = "This is the Subject line"
        '.Body = strbody
        'SendUsingAccount is new in Office 2007
        'Change Item(1)to the account number that you want to use
        '.SendUsingAccount = OutApp.Session.Accounts.Item(1)
        .Display '.Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
    Call HistEvoie
Else
    MsgBox "Aucun résultat trouvé"
End If
Application.ScreenUpdating = True
'--- Fermeture connexion ---
Cn.Close
Set Cn = Nothing
End Sub

当我手动搜索记录时，我会发现它们没有问题，如果在前10行中满足参数，则返回500k行的整个记录集，如果没有，则记录集为空。我将搜索列的格式设置为全部为文本，以确保数字/字符串类型没有奇怪的事情发生。该列包含加拿大和美国的邮政编码/邮政编码，并且可能包含破折号“-”，但乍一看似乎不是造成此问题的原因。

谢谢

空记录集（如果前10行没有结果）

0 个答案: