У меня есть этот код, который автоматически фильтрует на основе критериев, а затем копирует выбранные столбцы в новое письмо. Проблема, с которой я столкнулся, заключается в том, что если у меня менее 11 записей, данные, вставленные в прогноз, опускаются в нижнюю границу (очень странное поведение). Я пробовал другие номера столбцов, чтобы проверить теорию «меньше 11», и она ведет себя одинаково независимо от столбца, из которого я автоматически фильтрую. Я использую популярную функцию под названием RangetoHTML.
Вот код для моего кода автофильтра и функции RangetoHTML:
Sub EmailNoAppraisal()
ActiveSheet.Unprotect
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String
Dim LastRw As String
Dim r As Range
Set r = ActiveSheet.Range("$a$9:$bu$500")
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ActiveSheet.Range("$a$9:$bu$500").AutoFilter Field:=41, Criteria1:=""
ActiveSheet.Range("$a$9:$bu$500").AutoFilter Field:=2, Criteria1:="<>"
Range(Cells(r.Rows.Count + 1, 1), Cells(Rows.Count, Columns.Count)).EntireRow.Hidden = True
Range("$a$9:$bu$500").Sort Key1:=Range("L10"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveWindow.ScrollColumn = 41
Set rng = Nothing
' Only send the visible cells in the selection.
LastRw = ActiveSheet.Range("E9").End(xlDown).Row
Set rng = Application.Union(ActiveSheet.Range("A9:B" & LastRw), _
ActiveSheet.Range("AG9:AG" & LastRw), _
ActiveSheet.Range("C9:C" & LastRw), _
ActiveSheet.Range("E9:E" & LastRw), _
ActiveSheet.Range("I9:I" & LastRw), _
ActiveSheet.Range("H9:H" & LastRw), _
ActiveSheet.Range("O9:O" & LastRw), _
ActiveSheet.Range("E9:E" & LastRw), _
ActiveSheet.Range("Y9:Y" & LastRw), _
ActiveSheet.Range("AH9:AH" & LastRw), _
ActiveSheet.Range("AC9:AC" & LastRw), _
ActiveSheet.Range("AZ9:AZ" & LastRw), _
ActiveSheet.Range("AO9:AO" & LastRw), _
ActiveSheet.Range("BL9:BL" & LastRw))
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
.Display
End With
Signature = OutMail.HTMLBody
strbody = "Team, please see list below of loans that have no appraisal ordered. Please make sure that the loan notes indicate the point of contact for appraisal and that" & "<u><b> the fee is collected.</u></b>" & "<br />" & "<br />" & "<u><b>Summary:</u></b>" & "<br />" & "Loan Summary: " & ActiveSheet.Range("B1") & "<br />" & "Total" & Split(ActiveSheet.Range("B2").Text, ".")(0) & "<br />"
With OutMail
.to = "Team Cerrato"
'.cc =
.Subject = "Loans with appraisal not ordered"
.HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Range("A8").Value = "Current Filter = Loans with no appraisal ordered"
End Sub
Function RangetoHTML(rng As Range)
ActiveSheet.Unprotect
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 past the data in
rng.Borders.LineStyle = xlContinuous
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