Sub htmlщик26()Dim txta As String, k
 Dim txta1 As String
    Dim txtb As String
    Dim i&
    Dim a(), a1(), b()
    Excel.Worksheets("лист1").Activate
''    Open "c:\rab\ww.a2" For Output As #1
    'грузим с листа html минус 3 последних строки
    With Sheets("html")
        a = .Range("A1:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
    End With
''    Debug.Print LBound(a, 1)
''     Debug.Print LBound(a, 2)
''    Print #1, a(1, 1)
''    Print #1, "======================"
    'txt = ""
    k = 1
    For i = 1 To UBound(a)
    If a(i, 1) = "###" Then
    k = 2
    End If
    If k < 2 Then
        txta = txta & a(i, 1) & vbLf
    Else
    k = k + 1
    If k > 2 Then
        txta1 = txta1 & a(i, 1) & vbLf
    End If
    End If
    Next
    
''    Print #1, txta
''    Print #1, "======================"
''     Print #1, txta1
''    Print #1, "======================"
    'вставляем таблицу
    b = Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    'шапка
    txtb = txtb & "<thead>" & vbLf
        txtb = txtb & "<tr>" & vbLf
        txtb = txtb & "<th>" & b(1, 1) & "</th>" & vbLf
        txtb = txtb & "<th>" & b(1, 2) & "</th>" & vbLf
        txtb = txtb & "<th>" & b(1, 3) & "</th>" & vbLf
         txtb = txtb & "<th>" & b(1, 4) & "</th>" & vbLf
        
        txtb = txtb & "</tr>" & vbLf
        txtb = txtb & "</thead>" & vbLf
''     Print #1, txtb
''     Print #1, "======================"
    'таблица
    Dim s2
    For i = 2 To UBound(b)
    If b(i, 4) = "Япония" Then
    s2 = "<span class=japan>"
    ElseIf b(i, 4) = "Китай" Then
    s2 = "<span class=descr>"
    ElseIf b(i, 4) = "Германия" Then
    s2 = "<span class=germany>"
    ElseIf b(i, 4) = "США" Then
    s2 = "<span class=descr>"
    End If
  
        txtb = txtb & "<tr>" & vbLf
        txtb = txtb & "<td>" & s2 & b(i, 1) & "</span></td>" & vbLf
        txtb = txtb & "<td>" & s2 & b(i, 2) & "</span></td>" & vbLf
        txtb = txtb & "<td align=right>" & s2 & b(i, 3) & "</span></td>" & vbLf
        txtb = txtb & "<td>" & s2 & b(i, 4) & "</span></td>" & vbLf
        txtb = txtb & "</tr>" & vbLf
    Next
''     Print #1, txtb
''     Print #1, "======================"
    'добавляем последние 3 строки с листа html
    
    pth = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".htm" 'путь для сохранения + имя
    
    'сохраняем
    'Set fso = CreateObject("scripting.filesystemobject")
    'Set ts = fso.CreateTextFile(pth, True)
    'ts.Write txt
    'ts.Close
    'Set ts = Nothing
    'Set fso = Nothing
    
With CreateObject("ADODB.Stream")
    .Type = 2 'двоичный режим
    .Charset = "utf-8" 'кодировка
    .Open 'открываем
    .writetext txta 'записываем
    .writetext txtb
    .writetext txta1
    .SaveToFile pth, 2 'сохраняем
End With
''Close #1
    Beep
    MsgBox "Готово!"
End Sub