Excel VBA Макросы: Сохранение столбца в отдельный файл txt.

[Лекс]

Есть файл эксель с кучей листов (пример во вложении).
Необходимо сохранить первый столбец каждого листа в отдельный файл txt.

Есть код которым я пользовался, но он копирует весь лист а не первый столбец.

Sub SplitSheets()
    Dim s As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                                           'проходим во всем листам активной книги
        s.Copy                                                                                           'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".txt", FileFormat:=42  'сохраняем файл
        ActiveWorkbook.Close True
    Next
End Sub

[вложение удалено администратором]

[Администратор]

Макрос

Sub SplitSheets()

    Dim bk_src As Workbook, sh_src As Worksheet, bk_res As Workbook
   
   
    '1. Отключение монитора, чтобы ускорить макрос и чтобы не мигало.
    Application.ScreenUpdating = False
   
    '2. Присваиваем активному файлу имя 'bk_src', чтобы дальше в коде обращаться
        ' к файлу по этому имени.
    Set bk_src = ActiveWorkbook
   
    '3. Проходим во всем листам активной книги.
    For Each sh_src In bk_src.Worksheets
   
        '1) Создание нового файла и присвоение ему имени 'bk_res'.
            ' xlWBATWorksheet - означает, что в новом файле будет один лист.
        Set bk_res = Workbooks.Add(xlWBATWorksheet)
       
        '2) Копируем столбец A из листа-источника на лист-результат в столбец A.
            ' На исходном листе формулы, чтобы формулы не копировать, копируем
            ' с использованием 'PasteSpecial xlPasteValues'.
        sh_src.Columns("A").Copy
        bk_res.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
       
        '3) Сохраняем и закрываем файл.
        bk_res.SaveAs bk_src.Path & "\" & sh_src.Name & ".txt", FileFormat:=xlUnicodeText, Local:=True
        bk_res.Close True
       
    Next
   
    '4. Включение монитора.
    Application.ScreenUpdating = True
   
    '5. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[Лекс]

Отлично. Спасибо.

[Лекс]

Вопрос по этому макросу.
При копировании столбца из файла эксель в файл txt, строчки, в которых есть "запятая", помещаются в кавычки.
Пример. В экселе текст: Конечно, но
В текстовом файле этот текст: "Конечно, но"

Кроме запятой в ячейке может быть "точка с запятой".
Что нужно сделать, чтобы не было кавычек?

[Администратор]

Если в тексте есть запятая и точка с запятой, то способ создания файла, используемый в первом сообщении и в ответе 1, не подходит, т.к. будут добавляться кавычки или для запятой или для точки запятой.

[Администратор]

Вариант с использованием библиотеки 'Scripting' и объекта 'FileSystemObject'. Этот объекта в отличие от встроенного в VBA инструмента 'Open' умеет сохранять файл в юникод-формат. Но эта библиотека не будет работать на маке (операционная система 'Macintosh'), т.к. на маке этой библиотеки нет.

На листе-источнике не должно быть скрытых строк, иначе будет неправильно определена последняя строка.

Макрос

Sub SplitSheets()

    Dim bk_src As Workbook, sh_src As Worksheet
    Dim FN As String, fso As Object, file As Object
    Dim lr As Long, i As Long
   
   
    '1. Отключение монитора, чтобы ускорить макрос и чтобы не мигало.
    Application.ScreenUpdating = False
   
    '2. Создание объекта, который умеет работать с текстовыми файлами в unicode-формате.
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
   
    '3. Присваиваем активному файлу имя 'bk_src', чтобы дальше в коде обращаться
        ' к файлу по этому имени.
    Set bk_src = ActiveWorkbook
   
    '4. Проходим во всем листам активной книги.
    For Each sh_src In bk_src.Worksheets
   
        '1) Создание текстового файла.
        FN = bk_src.Path & "\" & sh_src.Name & ".txt"
        Set file = fso.OpenTextFile(FileName:=FN, IOMode:=2, Create:=True, Format:=-1)
       
        '2) Запись столбца A в текстовый файл. 'End' не ищет в скрытых строках.
        lr = sh_src.Cells(sh_src.Rows.Count, "A").End(xlUp).Row
        For i = 1 To lr - 1
            file.WriteLine sh_src.Cells(i, "A").Value
        Next i
        file.Write sh_src.Cells(i, "A").Value
       
        '3) Закрытие текстового файла с сохранением.
        file.Close
   
    Next
   
    '5. Включение монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[Лекс]

Благодарю. Работает.