複数のシートから電子メールを送信する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）