VBA代碼不會轉到下一個工作表以從多個工作表發送電子郵件

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（“ A：M”＆lastRow）.SpecialCells（xlCellTypeVisible）此行應設置為rng = sh.Range（“ A：M”＆lastRow）.SpecialCells（xlCellTypeVisible）