Dim Book As Workbook
Dim Путь As String

Rem Формирование пути к архивам
Путь = Path_2
If Right(Путь,  1 ) <> "\" Then Путь = Путь + "\"
Путь = Путь + File_2
Путь = Путь + ".htm"

Sheets(list).Activate
ActiveSheet.Copy

Rem Находим и сохраняем книгу, которая еще не сохранялась
For Each Book In Workbooks
    If Book.Path = "" Then
        Book.SaveAs Filename:=(Путь), FileFormat:=xlHtml
        Book.Close
    End If
Next Book

Dim Filename As Variant
Dim TDOpenTag As String, TDCloseTag As String
Dim CellContent As String
Dim Rng As Range
Dim R As Long, C As Integer
Dim Путь As String

Rem Формирование пути к архивам
Путь = Path_2
If Right(Путь,  1 ) <> "\" Then Путь = Путь + "\"
Путь = Путь + File_2
Путь = Путь + ".htm"

Rem Задаем координаты начала и конца области сбороса
Set Rng = Worksheets(list).Range(rang)

Rem Получение и присвоение имени файла
Filename = Application.GetSaveAsFilename(InitialFileName:=Путь, filefilter:="HTML Files(*.htm), *.htm")
If Filename = False Then Exit Sub

Rem Открываем файл для записи
Open Filename For Output As # 1 

Rem Записываем дискриптор <TABLE>
Print # 1 , "<TABLE BORDER=1 CELLPADDING=3>"

Rem Циклический просмотр ячеек
For R =  1  To Rng.Rows.Count
    Print # 1 , "<TR>"
        For C =  1  To Rng.Columns.Count
            TDOpenTag = "<TD ALIGN=RIGHT>"
            TDCloseTag = "</TD>"
            If Rng.Cells(R, C).Font.Bold Then
                TDOpenTag = TDOpenTag & "<B>"
                TDCloseTag = "</B>" & TDCloseTag
            End If
            If Rng.Cells(R, C).Font.Italic Then
                TDOpenTag = TDOpenTag & "<I>"
                TDCloseTag = "</I>" & TDCloseTag
            End If
            CellContent = Rng.Cells(R, C).Text
            Print # 1 , TDOpenTag + CellContent + TDCloseTag
        Next C
    Print # 1 , "</TR>"
Next R
Print # 1 , "</TABLE>"
Close # 1 

Book.SaveAs Filename:=(Путь), FileFormat:=xlHtml