Sub Mokus()
Const defPath = "c:\temp\"  'Путь к папке для сохранения файлов
Dim fileSaveName, rr As Range, n As Integer, i As Integer
If Dir(defPath, vbDirectory) = "" Then MkDir defPath
ChDir defPath
fileSaveName = Application.GetSaveAsFilename(Replace(ActiveWorkbook.Name, ".xls", ""), _
    "Text Files (*.html), *.html", , "Сохранение без лишних кавычек :)")
If fileSaveName <> False Then
    Open fileSaveName For Output As #1
    For Each rr In ActiveSheet.UsedRange.Rows
     n = rr.Cells.Count
     For i = 1 To n - 1
      Print #1, rr.Cells(i).Text;
     Next
     Print #1, rr.Cells(n)
    Next
Close #1
End If
End Sub

Function ChangeFileCharset(ByVal filename$, ByVal DestCharset$, _
                            Optional ByVal SourceCharset$) As Boolean
     ' функция перекодировки (смены кодировки) текстового файла
    ' В качестве параметров функция получает путь filename$ к текстовому файлу,
    ' и название кодировки DestCharset$ (в которую будет переведён файл)
    ' Функция возвращает TRUE, если перекодировка прошла успешно
    On Error Resume Next: Err.Clear
     With CreateObject("ADODB.Stream" ) 
      .Type = 2
         If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
        .Open
         .LoadFromFile filename$    ' загружаем данные из файла
        FileContent$ = .ReadText   ' считываем текст файла в переменную FileContent$
        .Close
         .Charset = DestCharset$    ' назначаем новую кодировку
        .Open
         .WriteText FileContent$
         .SaveToFile filename$, 2   ' сохраняем файл уже в новой кодировке
        .Close
     End With
     ChangeFileCharset = Err = 0
End Function