如何使用 VBA 填充数组

问题描述 投票：0回答：2

目标是发送一封电子邮件，其中包含代码作为单个电子邮件返回的值。

我明白了

运行时错误“6”：溢出

输出的是最后一个值，而不是所有值。

Sub Email()

Dim Outlook, OutApp, OutMail As Object
Dim EmailSubject As String, EmailSendTo As String, MailBody As String
Dim SigString As String, Signature As String, fpath As String
Dim Quarter As String, client() As Variant
Dim Alert As Date, Today As Date, Days As Integer, Due As Integer

Set Outlook = OpenOutlook

Quarter = Range("G4").Value
Set rng = Range(Range("G5"), Range("G" & Rows.Count).End(xlUp))

'Resize Array prior to loading data
ReDim client(rng.Rows.Count)

'Check column G for blank cells and return F cells
For Each Cell In rng
    If Cell.Offset(0, 1).Value = "" Then
        ReDim client(x)
        Alert = Cell.Offset(0, 0).Value
        Today = Format(Now(), "dd-mmm-yy")
        Days = Alert - Today
        Due = Days * -1
        client(x) = Cell.Offset(0, -3).Value & " " & Cell.Offset(0, -1).Value
    End If
Next
For x = LBound(client) To UBound(client)
    List = client(x) & vbNewLine
    List = List + List
Next x
        
'Check dates to send subject line'
If Days < 0 Then
    mail = True
    EmailSubject = Quarter & " Vat Returns are Overdue"
    MailBody = "<p>The Vat Returns are overdue by " & Due & " Days. See the clients below: </p>" & List
    ElseIf Days <= 14 Then
    mail = True
    EmailSubject = "Vat Returns are due within Two weeks"
    MailBody = "<p>The Vat Returns are due in " & Days & " Days. See the clients below: </p>" & List
End If  
    
'Fetch signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\.htm"
    Signature = GetBoiler(SigString)
    
'Fetch link for file location
    fpath = "K:
    
'Skip if mail=false
    If mail = True Then
    
'Send Mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(o)
        With OutMail
            .Subject = EmailSubject
            .To = ""
            '.bcc
            sHTML = "<HTML><BODY>"
            sHTML = sHTML & "<p>Hi, </p>"
            sHTML = sHTML & MailBody
            sHTML = sHTML & "<p>If the Vat Return have been filed, please update the database using the link below.</p>"
            sHTML = sHTML & "<A href='" & fpath & "'></A>"
            sHTML = sHTML & "<p>Regards,</p>"
            .HTMLBody = sHTML & Signature
            .HTMLBody = .HTMLBody & "</BODY></HTML>"
            .Display
        End With
        
        Set Outlook = Nothing
        Set OutMail = Nothing
        Set OutApp = Nothing
        
        mail = False
        EmailSendTo = ""
        
    End If
End Sub

此代码会在 Outlook 中返回一个打开的窗口，不显示新电子邮件。

我希望如果 G:G 列中的单元格为空白，则返回 F:F 列中的单元格值。

我希望代码存储这些值，然后发送电子邮件。
我可以编写代码将多封电子邮件发送到一个电子邮件地址，每封电子邮件中包含一个单元格值。
我想向包含所有（多个）单元格值的电子邮件地址发送一封电子邮件。

我已经取出了个人详细信息，但这不会影响运行代码。

excel vba autofilter
2个回答
0
投票

请尝试下一个改编的代码。如果过滤活动工作表的使用范围，则过滤“G:G”列的空白单元格，使用 

Subtotal
设置数组维度，并从“F:F”列返回数组。代码中有
Date
计算没有使用，我不明白在哪里使用......：

Sub NDJList()
 Dim List() As Variant, Alert As Date, Today As Date
 Dim Days As Integer, Due As Integer
 Dim rng As Range, Cell As Range, x As Long, rowsCount As Long

 If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

 'Determine the data to store:???
 Set rng = Range(Range("C4"), Range("C" & rows.count).End(xlUp))

 ActiveSheet.AutoFilter 7, "" 'filter the activesheet used range
 rowsCount = Application.WorksheetFunction.Subtotal(3, rng) - 1 'numbers of rows in discontinuous range, except headers one
 With rng
        Set blanks = .Offset(1).Resize(rng.rows.count - 1).SpecialCells(xlCellTypeVisible)
    
       'Resize Array prior to loading data
       ReDim List(rowsCount - 1) 'zero based array...
    
       'Loop through each cell in range and store value in Array
        For Each Cell In blanks
            'Alert = Cell.Offset(0, 4)   '??? not used...
            'Today = Format(Now(), "dd-mmm-yy") '??? not used...
            'Days = Alert - Today       '??? not used...
            List(x) = Cell.Offset(, 3).Value: x = x + 1
      Next Cell
 End With
 
  'Print values to Immediate Window
  For x = LBound(List) To UBound(List)
        Debug.Print List(x)
  Next x

End Sub

注释掉未使用的行。无论如何， 

Offset(,4)
应该从过滤列中返回，这意味着只有空白单元格，从而使相应的行引发错误......

未经测试，但应该可以工作。

0
投票

从过滤列中获取唯一字符串

enter image description here

用法

Sub GetNDJListTEST()
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Debug.Print GetNDJList(ws)
End Sub

截图中数据的结果：

S
T
J
U
Z
Q
I
O
P
D

功能

Function GetNDJList(ByVal ws As Worksheet) As String
    
    Const FIRST_ROW As Long = 4
    Const DATA_COLUMN As Long = 6
    Const FILTER_COLUMN As Long = 7
    Const FILTER_STRING As String = ""

    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim srg As Range, sdrg As Range, rOffset As Long, rCount As Long
    
    With ws.UsedRange
        rOffset = FIRST_ROW - .Row
        rCount = .Rows.Count - rOffset
        Set srg = .Resize(rCount).Offset(rOffset) ' has headers
        Set sdrg = srg.Resize(rCount - 1).Offset(1) ' no headers
    End With
           
    srg.AutoFilter FILTER_COLUMN, FILTER_STRING
    
    Dim drg As Range
    On Error Resume Next
        Set drg = sdrg.Columns(DATA_COLUMN).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ws.AutoFilterMode = False
        
    If drg Is Nothing Then Exit Function ' no filtered values
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim dCell As Range, dString As String
    
    For Each dCell In drg.Cells
        dString = CStr(dCell.Value)
        If Len(dString) > 0 Then
            If Not dict.Exists(dString) Then dict(dString) = Empty ' first occ.
        End If
    Next dCell
    
    If dict.Count = 0 Then Exit Function ' just blanks
    
    GetNDJList = Join(dict.Keys, vbLf)

End Function
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.