Question

我有一个VBA代码，可以根据列的值创建多个工作表，然后复制电子邮件正文中每个工作表的内容，以便发送给每个工作表的目标收件人。但是，该代码仅适用于第一张纸，并且不会继续到下一张纸。有人能指出我在这段代码中出错的地方吗？非常感谢您的协助。我引用了完整的代码，包括避免混淆的函数。

Sub Queries_Not_Replied()

    Cells.Select
    Cells.Unmerge
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    With selection
         .HorizontalAlignment = xlLeft
         .VerticalAlignment = xlTop
         .Orientation = 0
         .AddIndent = False
         .ShrinkToFit = False
         .ReadingOrder = xlLTR
    End With

    rows("1:5").Select
    selection.Delete Shift:=xlUp
    Columns("I").Select
    selection.Delete
    Columns("L").Select
    selection.Delete

    Cells.Select
        With selection.Borders
             .LineStyle = xlContinuous
             .Weight = xlThin
             .ColorIndex = xlAutomatic
        End With
    Cells.EntireColumn.AutoFit

    Columns("M").Select
    selection.Delete

    parse_data

'Remove Original Sheet
 Sheets("Sheet1").Select
ActiveWindow.SelectedSheets.Delete

Dim email As String
email = ActiveSheet.Range("M2").Value

Dim rng As Range
Dim sh As Worksheet
Dim OutApp As Object
Dim OutMail As Object

For Each sh In ThisWorkbook.Worksheets

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = ActiveSheet.Range("A:M" & lastRow).SpecialCells(xlCellTypeVisible)

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)

 With OutMail
     .To = email
     '.CC = Area Manager
     .Subject = "Queries From Banks Not Acted by your branch " &   ActiveSheet.Name
    .HTMLBody = RangetoHTML(rng)
    .Display
    '.Send
End With
On Error GoTo 0


    Set OutMail = Nothing
    Next sh
    Set OutApp = Nothing

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

 End Sub

Private Function parse_data()
   'Created and Modified Based on extendoffice.com code
   'How to split data into multiple worksheets based on column in Excel
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 11

    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.rows.Count, vcol).End(xlUp).Row
    title = "A1:L1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr

       On Error Resume Next

       If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0         
       Then
            ws.Cells(ws.rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
      End If
      Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
   ws.Columns(icol).Clear
       For i = 2 To UBound(myarr)
          ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""

          If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
               Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
          Else
                 Sheets(myarr(i) & "").Move       After:=Worksheets(Worksheets.Count)
          End If

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit

 'obtain email address
Dim mTxt As String
Count = 2
While Trim(Range("K" + Trim(Count)).Value) <> ""
        Select Case Trim(Range("K" + Trim(Count)).Value)
        Case "ABA"
            mTxt = "boy@gmail.com"
        Case "ADH"
            mTxt = "tothem@yahoo.com"
        Case "AIN"
            mTxt = "someone@yahoo.com"
        Case "AMB"
            mTxt = "somebody@gmail.com"
        Case "GMB"
            mTxt = "anybody@hotmail.com"
        End Select

    If Trim(Range("K" + Trim(Count)).Value) <> "" Then
        Range("M" + Trim(Count)).Value = mTxt
    Else
        Range("M" + Trim(Count)).Value = ""
    End If

    Count = Count + 1
    Wend

    Next
    ws.AutoFilterMode = False
    ws.Activate

End Function

Private Function RangetoHTML(rng As Range)
    ' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to paste the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With

   'Publish the sheet to a htm file
     With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     FileName:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
  End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

  'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Answer 1

设置rng = ActiveSheet.Range（＆＃34; A：M＆＃34;＆amp; lastRow）.SpecialCells（xlCellTypeVisible）这条线应该是设置rng = sh.Range（＆＃34; A：M＆＃34;＆amp; lastRow）.SpecialCells（xlCellTypeVisible）

VBA代码不会转到下一张表以从多张表发送电子邮件

1 个答案: