Страницы: 1
RSS
Сохранить с определенных строк в TXT
 
Здравствуйте, помогите допилить макрос для копирования текста из excel в текстовой ".txt"
1) при сохранении не подбирает с L2 данные формат "№000"
2) при сохранении в текст копирует почему-то пустые строки, копирую я со второй строки всегда
3) убрать переводы строк, заменив на пробелы (здесь коряво, но решилось)
4) с столбца I не сохраняется в формате дата
5) копируем с A2:J35 без пустых строк, пустые строки не копируем вообще
6) при выходе название должно выглядеть так  №017 06.04.2018 Пт., вр.05-02-34 Простые письма
Пример приложен
Изменено: Goldenito - 06.04.2018 12:14:06
 
Код
Sub SaveTXT()
Dim fp$, txt$, aa As Range, ll&
fp = "D:\" & Format([L1], "№000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt"
ll = 2: txt = ""
Open fp For Output As #1
Print #1, fp 'путь и полное название файла
Print #1, Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2) 'название без пути, но с расширением файла
Print #1, Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") 'без пути и расширения
Print #1, Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2, Len(Format([L1], "№000"))) 'только "№0000"
For Each aa In [C2:J35]
  If Len(Range("C" & ll)) > 0 Then
    If aa.EntireRow.Row = ll Then
      txt = txt & CStr(aa) & vbTab
    Else
      Print #1, ll - 1 & vbTab & Left$(Replace$(txt, Chr(10), " "), Len(Replace$(txt, Chr(10), " ")) - 1)
      ll = ll + 1: txt = CStr(aa) & vbTab
    End If
  End If
Next
Close #1
End Sub
Изменено: Anchoret - 07.04.2018 12:41:24
 
Anchoret, спасибо большое, проверяю
 
Anchoret, а как убрать лишние пробелы в конце строки
и название файла скопировать в первую строку
и если можно нумерацию строк копируемых в текст данных с С2;J35
1. текст
2. текст
Изменено: Goldenito - 06.04.2018 13:37:38
 
Goldenito,а подумать?
 
Anchoret, попробую если получится
 
Goldenito, я обновил пост #2 несколько часов назад. не проверял, но должно работать.
 
Цитата
Anchoret написал:
не проверял, но должно работать.
ok, не выполняется остановился на Open fp For Output As 1
Изменено: Goldenito - 07.04.2018 01:01:27
 
Goldenito, перед 1 поставьте решетку.
 
Anchoret, спасибо работает замечательно
проблема была в [l1], "¹000 "
только не путь копировать, а имя файла как сделать без ".txt"
Код
Sub SaveTXT()
Dim fp$, txt$, aa As Range, ll&
fp = "D:\" & Format([l1], "№000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt"
ll = 2: txt = ""
Open fp For Output As #1
Print #1, fp
For Each aa In [C2:J35]
  If Len(Range("C" & ll)) > 0 Then
    If aa.EntireRow.Row = ll Then
      txt = txt & CStr(aa) & vbTab
    Else
      Print #1, ll - 1 & vbTab & Left$(Replace$(txt, Chr(10), " "), Len(Replace$(txt, Chr(10), " ")) - 1)
      ll = ll + 1: txt = CStr(aa) & vbTab
    End If
  End If
Next
Close #1
End Sub
Изменено: Goldenito - 07.04.2018 13:51:15
 
Goldenito, а теперь снова взгляните на пост 2
 
Цитата
Anchoret написал:
взгляните на пост 2
спасибо отлично вышло, огромное Вам спасибо, помогли безмерно
оставил так
Код
Sub SaveTXT()
Dim fp$, txt$, aa As Range, ll&
fp = "D:\" & Format([L1], "№000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt"
ll = 2: txt = ""
Open fp For Output As #1
'Print #1, fp 'путь и полное название файла
'Print #1, Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2) 'название без пути, но с расширением файла
Print #1, Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") 'без пути и расширения
'Print #1, Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2, Len(Format([L1], "№000"))) 'только "№0000"
For Each aa In [C2:J35]
  If Len(Range("C" & ll)) > 0 Then
    If aa.EntireRow.Row = ll Then
      txt = txt & CStr(aa) & vbTab
    Else
      Print #1, ll - 1 & vbTab & Left$(Replace$(txt, Chr(10), " "), Len(Replace$(txt, Chr(10), " ")) - 1)
      ll = ll + 1: txt = CStr(aa) & vbTab
    End If
  End If
Next
Close #1
End Sub
 
Anchoret, такой вопрос возник при сохранении в текстовик, текст сохраняется в ANSI кодировке, как его сохранять сразу в UTF-8 без BOM
Изменено: Goldenito - 07.04.2018 15:25:02
 
Доброе время суток
Цитата
Goldenito написал:
как его сохранять сразу в UTF-8
В инете ничего нет? Или форум - это такой сири и Ok google?
 
Андрей VG, я видел, они идут как функции
Код
Function EncodeUTF8noBOM(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 4095: t = Chr(AscW(l) \ 64 \ 64 + 224) & Chr(AscW(l) \ 64) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Is > 127: t = Chr(AscW(l) \ 64 + 192) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Else: t = l
        End Select
        EncodeUTF8noBOM = EncodeUTF8noBOM & t
    Next
End Function
копировать просто в макрос?
что то у меня не получается связать
и как после сохранения текстовика, сохраненный файл показать в открытом виде
Изменено: Goldenito - 07.04.2018 19:20:17
 
Код
Sub SaveTXT_UTF8()
Dim fp$, txt$, aa As Range, ll&, ADOSt As Object, a%
fp = "D:\" & Format([L1], "№000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt"
ll = 2: txt = ""
Set ADOSt = CreateObject("ADODB.Stream")
ADOSt.Open: ADOSt.Charset = "utf-8"
ADOSt.WriteText Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") & vbCrLf
For Each aa In [C2:J35]
  If Len(Range("C" & ll)) > 0 Then
    If aa.EntireRow.Row = ll Then
      txt = txt & Replace$(CStr(aa), Chr(10), " ") & vbTab
    Else
      txt = ll - 1 & vbTab & Left$(txt, Len(txt) - 1) & vbCrLf: ADOSt.WriteText txt
      ll = ll + 1: txt = Replace$(CStr(aa), Chr(10), " ") & vbTab
    End If
  End If
Next
ADOSt.SaveToFile fp, 2
ADOSt.Close
Set ADOSt = Nothing
End Sub
Изменено: Anchoret - 07.04.2018 20:25:32
 
Anchoret, все супер, остается подумать мне как добить "utf-8noBOM"
большое спасибо за огромный труд
Изменено: Goldenito - 07.04.2018 21:10:56
 
Goldenito, а чем этот несчастный BOM помешал? Кракозябры в начале текста или что?
 
Anchoret, некоторые иностранные языки не поддерживает, к примеру грузинский язык
нет поддерживает, но при редактировании (изменении) файла переводится на UTF-8 без BOM
Изменено: Goldenito - 07.04.2018 21:26:12
 
Goldenito, если не ошибаюсь BOM - это цифровой (три байта в начале строки или файла) маркер сообщающий тип кодировки. Нет?
 
Цитата
Anchoret написал:
BOM - это цифровой (три байта в начале строки или файла)
да все верно, в принципе было бы лучше без BOM если получится
 
Goldenito, значит выбранный вариант первичного решения с текстом (пост 12) + найденная вами функция. Применять ее после "Print #1,". Т.е.:
Код
Print #1,EncodeUTF8noBOM(...)'точки - это то, что стояло после запятой
 
Цитата
Goldenito написал:
в принципе было бы лучше без BOM если получится
Самое простое, перечитать файл, как байт массив после конвертации с Adodb.Stream и пере сохранить без первых трёх байтов, опять же как бинарный файл.Спешу, как голый в баню :(  Почитайте варианты.
Изменено: Андрей VG - 07.04.2018 22:26:50
 
Цитата
Anchoret написал:
Print #1,EncodeUTF8noBOM(...)'точки - это то, что стояло после запятой
иероглифы вышли)
Код
Sub SaveTXT()
Dim fp$, txt$, aa As Range, ll&
fp = "D:\" & Format([L1], "¹000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt"
ll = 2: txt = ""
Open fp For Output As #1
'Print #1, fp 'путь и полное название файла
'Print #1, Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2) 'название без пути, но с расширением файла
'Print #1, Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") 'без пути и расширения
Print #1, Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") 'без пути и расширения
'Print #1, Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2, Len(Format([L1], "¹000"))) 'только "¹0000"
For Each aa In [C2:J35]
  If Len(Range("C" & ll)) > 0 Then
    If aa.EntireRow.Row = ll Then
      txt = txt & CStr(aa) & vbTab
    Else
      Print #1, EncodeUTF8noBOM(ll - 1 & vbTab & Left$(Replace$(txt, Chr(10), " "), Len(Replace$(txt, Chr(10), " ")) - 1))
      ll = ll + 1: txt = CStr(aa) & vbTab
    End If
  End If
Next
Close #1
End Sub

'Функция перекодировки текста в UTF-8 без BOM
Function EncodeUTF8noBOM(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 4095: t = Chr(AscW(l) \ 64 \ 64 + 224) & Chr(AscW(l) \ 64) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Is > 127: t = Chr(AscW(l) \ 64 + 192) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Else: t = l
        End Select
        EncodeUTF8noBOM = EncodeUTF8noBOM & t
    Next
End Function

 
Goldenito, значит остается вариант с байтовой выгрузкой по совету Андрей VG.
 
Андрей VG, не смог применить, для меня это сложно
 
Anchoret, понял, тогда сойдет последнее там вышло все гладко

в итоге я остановился и доработал еще кое-где для удобства )
Спасибо за помощь в начале совершенства кода
Код
  Declare PtrSafe Function MessageBoxTimeOut Lib "User32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As VbMsgBoxStyle, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long
  Declare PtrSafe Function GetSystemMenu Lib "User32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
  Declare PtrSafe Function RemoveMenu Lib "User32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
  Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Sub SaveTXT_UTF8()
Dim fp$, txt$, aa As Range, ll&, ADOSt As Object, a%
    On Error Resume Next
    ' создаём папку для файла, если её ещё нет
    MkDir ThisWorkbook.Path & "\" & Range("L2")
    ' выбираем стартовую папку
    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & Range("L2")
    ' вывод диалогового окна для запроса имени сохраняемого файла
    Filename = Application.GetSaveAsFilename(Format([L1], "№000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt", "Текстовые файлы (*.txt), ", , "Введите имя файла для сохраняемого отчёта", "Сохранить")
    ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
    If VarType(Filename) = vbBoolean Then Exit Sub
    
    fp = Filename 'копирует в папку
    ll = 2: txt = ""
    Set ADOSt = CreateObject("ADODB.Stream")
    ADOSt.Open: ADOSt.Charset = "utf-8"
    ADOSt.WriteText Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") & vbCrLf
    For Each aa In [C2:J35]
  If Len(Range("C" & ll)) > 0 Then
    If aa.EntireRow.Row = ll Then
      txt = txt & Replace$(CStr(aa), Chr(10), " ") & vbTab
    Else
      txt = ll - 1 & vbTab & Left$(txt, Len(txt) - 1) & vbCrLf: ADOSt.WriteText txt
      ll = ll + 1: txt = Replace$(CStr(aa), Chr(10), " ") & vbTab
    End If
  End If
Next
ADOSt.SaveToFile fp, 2
ADOSt.Close
Set ADOSt = Nothing
    Const lSeconds As Long = 3
    MessageBoxTimeOut 0, "Файл сформирован. Папка откроется через 3 секунды", "Goldenito", vbInformation + vbOKOnly, 0&, lSeconds * 1000
    Shell "explorer.exe " & ThisWorkbook.Path & "\" & Range("L2"), vbMaximizedFocus 'vbNormalFocus в нормальном режиме или vbMaximizedFocus в полном раскрытом окне
End Sub
Изменено: Goldenito - 08.04.2018 03:00:01
Страницы: 1
Наверх