时间戳

首页 > 解决方案 > 循环通过排除指定工作表的工作表

excel - 循环通过排除指定工作表的工作表

问题描述

我想从单个工作簿中的指定工作表中获取数据，然后从这些工作表中创建单独的电子邮件。

代码不会为每个工作表执行操作，然后移动到下一个。

我还想从操作中排除指定的工作表。

我在一个单独的模块中利用 Ron DeBruin 的RangetoHtml函数。

Sub ClientEvent_Email_Generation()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim count_row, count_col As Integer
    Dim Event_Table_Data As Range
    Dim Event2_Table_Data As Range
    Dim strl As String, STR2 As String, STR3 As String
    Dim WS As Worksheet
    Dim I As Integer
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    For Each WS In ThisWorkbook.Sheets
    
    WS.Activate
    
    If ActiveSheet.Name <> "DATA INPUT" Then Or "FORMATTED DATA TABLE" Or "REP CODE MAPPING TABLE" Or "IDEAS TAB" Then
    
    count_row = WorksheetFunction.CountA(Range("A10", Range("a10").End(xlDown)))
    count_col = WorksheetFunction.CountA(Range("A10", Range("a10").End(xlToRight)))
    
    Set Event_Table_Data = ActiveSheet.Cells.Range(Cells(9, 1), Cells(count_row, count_col)) 
    Set Event2_Table_Data = Sheets("w61").Range(Cells(9, 1), Cells(count_row, count_col)) 
    
    str1 = "<BODY style=font-size:12pt;font-family:Times New Roman>" & _
    "Hello " & Range("L3").Value & ",<br><br>The following account(s) listed below appear to have an upcoming event<br>"
    
    STR2 = "<br>Included are suggestions for an activity which may fit your client's needs.<br>"
    
    STR3 = "<br>You may place an order, or contact us for alternate ideas if these don't fit your client."
    
    On Error Resume Next
        With OutMail
        .To = ActiveSheet.Range("l4").Value
        .cc = ""
        .bcc = ""
        .Subject = "Upcoming Event  In Your Clients' Account(s)"
        .display
        .HTMLBody = str1 & RangetoHTML(Event_Table_Data) & STR2 & RangetoHTML(Event2_Table_Data) & STR3 & .HTMLBody
        
        End With
        On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    End If
    
    Next WS
    
End Sub

标签： excelvbaloopsoutlook

解决方案

循环（迭代）工作表

  • 以下将遍历包含此代码 ( ) 的工作簿中的每个工作表，并打印(数组)ThisWorkbook中不包含的每个工作表名称以及以单元格开头的“非空”范围到(VBE: + 。Exceptions ListExceptionsA9Immediate windowCtrlG
  • 首先按原样运行它以查看结果是否令人满意，然后才在需要限定范围和单元格的地方添加您的电子邮件代码（不清楚），即使用ws代替ActiveSheet和ws.前面Cells或Range( ws.Cells(...)，ws.Range(...)如果有的话，或者是循环中当前工作表的一部分。
  • 可能有更可靠的方法（请参阅Error in find last used cell in Excel with VBA 的答案）来定义（创建对）范围的引用，但这里的焦点设置在循环上（使用更不可靠）。ACount
Option Explicit

Sub loopThroughWorksheets()
    
    Const sFirst As String = "A9"
    Const ExceptionsList As String _
        = "DATA INPUT,FORMATTED DATA TABLE,REP CODE MAPPING TABLE,IDEAS TAB"
    
    Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet
    Dim srg As Range ' "Event_Table_Data"
    Dim fCell As Range
    Dim rCount As Long, cCount As Long
    
    For Each sws In wb.Worksheets
        If IsError(Application.Match(sws.Name, Exceptions, 0)) Then
            Set fCell = sws.Range(sFirst)
            rCount = sws.Range(fCell, fCell.End(xlDown)).Cells.Count
            cCount = sws.Range(fCell, fCell.End(xlToRight)).Cells.Count
            Set srg = fCell.Resize(rCount, cCount)
            ' e.g.:
            Debug.Print sws.Name, srg.Address
            
            ' Your email code (per worksheet) here.
        
        'Else
            ' Worksheet is in Exceptions Array: do nothing, or...
        End If
    Next sws

End Sub

推荐阅读