Копирование данных из листа в файл html по электронной почте

Question

Я собираю данные из разных листов Excel и вставляю таблицу и содержимое на одном листе, а затем перетаскиваю это в файл html в Outlook.

При вставке данных из листа в html-файл вычисляется количество столбцов, в которых присутствуют данные.

Для примера на одном листе я наклеил текст, который составляет около 500 символов в первой строке. В следующей строке я вставил таблицу 5 * 10. При копировании данных в html-файл он вычисляет только 10 столбцов и копирует данные, которые на скриншоте желтого цвета.

Как скопировать все данные из Excel в html-файл.

Если я использую Sheet.UsedRange, то на основе столбца он копирует данные.

Код:

 
    Dim rng As Range 
    Dim OutApp As Object 
    Dim OutMail As Object 

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

    Dim htmlContent 
    Dim RangetoHTML 
    Dim lastColumn 
    Dim lastRow 
    Dim LastCol 
    Dim TempFile As String 

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

    For Each ws In ActiveWorkbook.Worksheets 
    If (ws.Name "Signature" And ws.Name "URL") Then 
    Set rng = Nothing 
    Set rng = ws.UsedRange 

    lastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row 
    Set rng = Range(Cells(1, 1), Cells(lastRow, 20)) 

    'Publish the sheet to a htm file 
    With ActiveWorkbook.PublishObjects.Add(_ 
     SourceType:=xlSourceRange, _ 
     Filename:=TempFile, _ 
     Sheet:=ws.Name, _ 
     Source:=ws.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=") 



    htmlContent = htmlContent & RangetoHTML 
    'You can also use a sheet name 
    'Set rng = Sheets("YourSheet").UsedRange 
    End If 
    Next ws 

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

    On Error Resume Next 
    With OutMail 
     .To = "sagarwal4@dow.com" 
     .CC = "" 
     .BCC = "" 
     .Subject = "This is the Subject line" 
     .HTMLBody = htmlContent 
     .Send 'or use .Display 
    End With 
    On Error GoTo 0 

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

    Set OutMail = Nothing 
    Set OutApp = Nothing 

Answer 1

использовать что-то вроде этого, вместо:

Dim lastCell As Excel.Range 

Set lastCell = Cells.Find(What:="*", After:=Cells(1, 1), Lookat:=xlPart, _ 
     LookIn:=xlFormulas, SearchOrder:=xlByRows, _ 
     SearchDirection:=xlPrevious, MatchCase:=False) 

Range("A1", lastCell).Copy 

'// Rest of code here ....