Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Сохранение текста из столбца А, в кодировке unicode
 
Доброе утро уважаемые форумчане!
Есть у меня код, который может находить последнюю занятую ячейку в столбце А и сохранять с 1 по последнюю занятую ячейку в текстовый файл на диске С:
Код
Sub СОХРАСТ()
Sheets("Астана".Select
Dim i As Long, s As String
i = Cells(1, 1).End(xlDown).Row 'последняя строка
ReDim arr(1 To i) As String
For i = 1 To UBound(arr)
arr(i) = Cells(i, 1)
Next i
s = Join(arr, vbCrLf)
Open "C:\Астана.txt" For Output As #1 'сохранение
Print #1, s
Close #1 End Sub
Беда в том, что сохраняет по умолчанию текст в кодировке Windows 1251.
У меня в столбце есть спецсимволы (буквы казахского алфавита) и они сохраняются знаками "?" в текстовом файле.
Через запись макросов удалось вытащить такой код:
Код
ActiveWorkbook.SaveAs Filename:= _
        "C:\Астана.txt" _
        , FileFormat:=xlUnicodeText, CreateBackup:=False
Но как прикрутить к коду команду "FileFormat:=xlUnicodeText" увы не могу понять.
Может есть какие-то другие методы сохранения занятых ячеек столбца в текстовый файл?
Файл для наглядности и скрины текста (вдруг у кого не откроется) прилагаю вложением.

Файлы удалены: превышение допустимого размера вложения [МОДЕРАТОР]
Изменено: Владислав - 15 Апр 2015 10:27:03
 
перекодировщик отсюда попробуйте... как-то так для вашего 1-го столбца (наверно):
Код
Sub Create_Unicode_text_file()
  Dim x As Long, lr&, strArray
  Dim strWholeFile As String
   
Sheets("Астана").Range("D1").Value = TimeValue(Now)
Sheets("Астана").Range("E1").Value = DateValue(Now)
lr = Cells(1, 1).End(xlDown).Row     'последняя строка  

ReDim strArray(1 To lr)  
  For x = 1 To lr - 1
    strWholeFile = strWholeFile & Cells(x, 1).Value & vbCrLf
  Next
  strWholeFile = strWholeFile & Cells(x, 1).Value ' special case w/o vbCrlf
   
  Dim ADOStream
  Set ADOStream = CreateObject("ADODB.Stream")
   
  With ADOStream
    .Open
    .Position = 0
    .Charset = "unicode"
    .WriteText strWholeFile
    .SaveToFile ThisWorkbook.Path & "\Астана.txt", 2 ' overwrite if exists
    .Close
  End With
End Sub
Изменено: JeyCi - 15 Апр 2015 09:02:04
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
Так попробуйте:
Код
s = Join(arr, vbCrLf)
s = StrConv(s, vbUnicode)                                    'utf-16
Open ThisWorkbook.Path & "\Астана.txt" For Output As #1      'сохранение
Print #1, s
Close #1
End Sub
 
JeyCi- Спасибо огромное!
Код работает прекрасно!!!  
 
Владислав,  я там с последней строкой думала-исправляла чуток... но, вобщем, суть такова и осталась... просто возьмите текущий (после исправлений итоговый вариант) - чтобы я там вдруг чего случайно не удалила (пока наводила красоту)... успехов  
Изменено: JeyCi - 15 Апр 2015 09:06:31
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
Страницы: 1
Читают тему (гостей: 1)