Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Перевод csv в txt с добавлением данных и упаковывание в zip - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перевод csv в txt с добавлением данных и упаковывание в zip (Макросы/Sub)
Перевод csv в txt с добавлением данных и упаковывание в zip
skobelev Дата: Вторник, 15.11.2016, 11:32 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день! Прошу помочь написать макрос. Суть: есть файл .csv требуется этот файл перевести в .txt и запаковать в .zip с определенным именем (желательно, чтобы имя автоматически присваивалось по шаблону, может подтягивалось бы из таблицы...Допустим, если исходник с именем 2.csv, то конечный файл архива должен быть 092016111002.txt.zip, а 3.csv будет 092016111003.txt.zip).

PS: последний раз макрос писал на лабораторной в институте...Ребят, помощь нужна в короткие сроки, поставили задачу мне за пару дней с этим разобраться.
К сообщению приложен файл: 1808721.csv(0Kb) · 092016111001.tx.zip(0Kb)


Сообщение отредактировал Manyasha - Среда, 16.11.2016, 11:22
 
Ответить
СообщениеДобрый день! Прошу помочь написать макрос. Суть: есть файл .csv требуется этот файл перевести в .txt и запаковать в .zip с определенным именем (желательно, чтобы имя автоматически присваивалось по шаблону, может подтягивалось бы из таблицы...Допустим, если исходник с именем 2.csv, то конечный файл архива должен быть 092016111002.txt.zip, а 3.csv будет 092016111003.txt.zip).

PS: последний раз макрос писал на лабораторной в институте...Ребят, помощь нужна в короткие сроки, поставили задачу мне за пару дней с этим разобраться.

Автор - skobelev
Дата добавления - 15.11.2016 в 11:32
skobelev Дата: Вторник, 15.11.2016, 11:38 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Прошу прощения, видимо из-за фаервола на работе создалось 3 одинаковые темы) Че т не нашел как удалить созданные темы...
 
Ответить
СообщениеПрошу прощения, видимо из-за фаервола на работе создалось 3 одинаковые темы) Че т не нашел как удалить созданные темы...

Автор - skobelev
Дата добавления - 15.11.2016 в 11:38
Manyasha Дата: Вторник, 15.11.2016, 11:39 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 1582
Репутация: 659 ±
Замечаний: 0% ±

Excel 2007, 2010
skobelev, удалила


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеskobelev, удалила

Автор - Manyasha
Дата добавления - 15.11.2016 в 11:39
skobelev Дата: Вторник, 15.11.2016, 11:41 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, Спасиб
 
Ответить
СообщениеManyasha, Спасиб

Автор - skobelev
Дата добавления - 15.11.2016 в 11:41
SLAVICK Дата: Вторник, 15.11.2016, 12:32 | Сообщение № 5
Группа: Модераторы
Ранг: Старожил
Сообщений: 1834
Репутация: 613 ±
Замечаний: 0% ±

2007,2010,2013,2016
Можно так:
[vba]
Код
Sub d()
Dim c As Range, Fn$, An$
For Each c In [a2:a5]
    Zipp c.Offset(, 1).Value, c.Value
Next
End Sub
Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
[/vba]

В первую колонку вставьте имена своих файлов. Вторая формульно высчитывает новое имя
К сообщению приложен файл: 9740523.xlsm(23Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
СообщениеМожно так:
[vba]
Код
Sub d()
Dim c As Range, Fn$, An$
For Each c In [a2:a5]
    Zipp c.Offset(, 1).Value, c.Value
Next
End Sub
Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
[/vba]

В первую колонку вставьте имена своих файлов. Вторая формульно высчитывает новое имя

Автор - SLAVICK
Дата добавления - 15.11.2016 в 12:32
skobelev Дата: Вторник, 15.11.2016, 13:12 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
SLAVICK, Очень не плохо, спасибо!, Но необходимо чтобы файл внутри был расширения .txt и с именем как файл .zip только без .zip (если zip будет 92016111001.txt.zip, то внутри архива должен быть файл 92016111001.txt).
 
Ответить
СообщениеSLAVICK, Очень не плохо, спасибо!, Но необходимо чтобы файл внутри был расширения .txt и с именем как файл .zip только без .zip (если zip будет 92016111001.txt.zip, то внутри архива должен быть файл 92016111001.txt).

Автор - skobelev
Дата добавления - 15.11.2016 в 13:12
SLAVICK Дата: Вторник, 15.11.2016, 13:23 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 1834
Репутация: 613 ±
Замечаний: 0% ±

2007,2010,2013,2016
необходимо чтобы файл внутри был расширения .txt и с именем как файл .zip только без .zip

ну тогда вместо первого макроса так:
[vba]
Код
Sub d()
Dim c As Range, Fn$, An$
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each c In [a2:a5]
    Call objFSO.CopyFile(c.Value, c.Offset(, 1).Value)   ' copy file as newFile
    Zipp c.Offset(, 2).Value, c.Offset(, 1).Value
    Kill c.Offset(, 1).Value
Next
End Sub
[/vba]
К сообщению приложен файл: 4785376.xlsm(22Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
необходимо чтобы файл внутри был расширения .txt и с именем как файл .zip только без .zip

ну тогда вместо первого макроса так:
[vba]
Код
Sub d()
Dim c As Range, Fn$, An$
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each c In [a2:a5]
    Call objFSO.CopyFile(c.Value, c.Offset(, 1).Value)   ' copy file as newFile
    Zipp c.Offset(, 2).Value, c.Offset(, 1).Value
    Kill c.Offset(, 1).Value
Next
End Sub
[/vba]

Автор - SLAVICK
Дата добавления - 15.11.2016 в 13:23
Manyasha Дата: Вторник, 15.11.2016, 13:30 | Сообщение № 8
Группа: Модераторы
Ранг: Старожил
Сообщений: 1582
Репутация: 659 ±
Замечаний: 0% ±

Excel 2007, 2010
Еще один вариант. Только у меня 1 файл обрабатывается:
[vba]
Код
Sub csvToTxt()
    Dim pathTxt$, temp$, nameTxt$
    Dim rarName$, appWinRar$, str$
    Dim lr&, lc&, i&, j&
    nameTxt = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)
    pathTxt = ActiveWorkbook.Path & "\" & "092016111" & Format(nameTxt, "000") & ".txt"
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    Open pathTxt For Output As #1
        For i = 1 To lr
            temp = i - 1 & ":"
            For j = 1 To lc
                temp = temp & Cells(i, j) & ";"
            Next j
            Print #1, temp
        Next i
    Close #1
    appWinRar = "C:\Program Files\WinRAR\WinRAR.exe a -ep1 -df"
    rarName = ActiveWorkbook.Path & "\" & "092016111" & Format(nameTxt, "000") & ".zip"
    str = appWinRar & " """ & rarName & """ """ & pathTxt & """ "
    Shell str, vbHide
End Sub
[/vba]
К сообщению приложен файл: 8990054.xlsm(18Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804


Сообщение отредактировал Manyasha - Вторник, 15.11.2016, 13:32
 
Ответить
СообщениеЕще один вариант. Только у меня 1 файл обрабатывается:
[vba]
Код
Sub csvToTxt()
    Dim pathTxt$, temp$, nameTxt$
    Dim rarName$, appWinRar$, str$
    Dim lr&, lc&, i&, j&
    nameTxt = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)
    pathTxt = ActiveWorkbook.Path & "\" & "092016111" & Format(nameTxt, "000") & ".txt"
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    Open pathTxt For Output As #1
        For i = 1 To lr
            temp = i - 1 & ":"
            For j = 1 To lc
                temp = temp & Cells(i, j) & ";"
            Next j
            Print #1, temp
        Next i
    Close #1
    appWinRar = "C:\Program Files\WinRAR\WinRAR.exe a -ep1 -df"
    rarName = ActiveWorkbook.Path & "\" & "092016111" & Format(nameTxt, "000") & ".zip"
    str = appWinRar & " """ & rarName & """ """ & pathTxt & """ "
    Shell str, vbHide
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 15.11.2016 в 13:30
skobelev Дата: Вторник, 15.11.2016, 14:37 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
SLAVICK, чего-то не хватает, ругается на утерю связи с элементом WorkWithFiles.xla
 
Ответить
СообщениеSLAVICK, чего-то не хватает, ругается на утерю связи с элементом WorkWithFiles.xla

Автор - skobelev
Дата добавления - 15.11.2016 в 14:37
skobelev Дата: Вторник, 15.11.2016, 14:49 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, ммм, прям хочется развить и Ваш макрос :) , я двумя скриптами делал, то что вы в один оформили)) Хочется конечно, чтобы все файлики разом, как у SLAVICK, чтобы по заранее созданному шаблону упаковалось. Но и на этом большое спасибо вам Manyasha и SLAVICK , может что-то еще скинете, если время будет у вас :D
 
Ответить
СообщениеManyasha, ммм, прям хочется развить и Ваш макрос :) , я двумя скриптами делал, то что вы в один оформили)) Хочется конечно, чтобы все файлики разом, как у SLAVICK, чтобы по заранее созданному шаблону упаковалось. Но и на этом большое спасибо вам Manyasha и SLAVICK , может что-то еще скинете, если время будет у вас :D

Автор - skobelev
Дата добавления - 15.11.2016 в 14:49
SLAVICK Дата: Вторник, 15.11.2016, 14:53 | Сообщение № 11
Группа: Модераторы
Ранг: Старожил
Сообщений: 1834
Репутация: 613 ±
Замечаний: 0% ±

2007,2010,2013,2016
ругается на утерю связи с элементом WorkWithFiles.xla

Это у меня такая же функция в надстройке была - попробуйте сейчас.

Что у Вас за браузер - поменяйте - сообщения троит.
К сообщению приложен файл: 4785376-1-1-.xlsm(21Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
ругается на утерю связи с элементом WorkWithFiles.xla

Это у меня такая же функция в надстройке была - попробуйте сейчас.

Что у Вас за браузер - поменяйте - сообщения троит.

Автор - SLAVICK
Дата добавления - 15.11.2016 в 14:53
skobelev Дата: Среда, 16.11.2016, 05:50 | Сообщение № 12
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, Доброе утро! А можно Вас еще попросить дополнить макрос, чтобы до сохранения вставлялся столбец с цифрой 1 и внутри текстового файла получались бы теже строки как в вашем варианте только в конце еще "1;" (пример одной строки файла: 0:50,356;321,856;322;1; ) ?) Я бы был счастлив)))
 
Ответить
СообщениеManyasha, Доброе утро! А можно Вас еще попросить дополнить макрос, чтобы до сохранения вставлялся столбец с цифрой 1 и внутри текстового файла получались бы теже строки как в вашем варианте только в конце еще "1;" (пример одной строки файла: 0:50,356;321,856;322;1; ) ?) Я бы был счастлив)))

Автор - skobelev
Дата добавления - 16.11.2016 в 05:50
skobelev Дата: Среда, 16.11.2016, 06:23 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
SLAVICK, Доброе утро! Всё бы хорошо, но структура внутри текстового файла не соответствует моей... Попробую конечно объединить труды и ваши SLAVICK и Manyasha , но чувствую у меня не получится))
 
Ответить
СообщениеSLAVICK, Доброе утро! Всё бы хорошо, но структура внутри текстового файла не соответствует моей... Попробую конечно объединить труды и ваши SLAVICK и Manyasha , но чувствую у меня не получится))

Автор - skobelev
Дата добавления - 16.11.2016 в 06:23
skobelev Дата: Среда, 16.11.2016, 08:14 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, В принципе очень грубо, но добавил "1" в ваш код)))
[vba]
Код
Sub csvToTxt()

    Dim pathTxt$, temp$, nameTxt$

    Dim rarName$, appWinRar$, str$

    Dim lr&, lc&, i&, j&

    Range("D1").Select

    ActiveCell.FormulaR1C1 = "1"

    Selection.AutoFill Destination:=Range("D1:3600"), Type:=xlFillDefault

    nameTxt = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)

    pathTxt = ActiveWorkbook.Path & "\" & "09" & Format(nameTxt, "000") & ".txt"

    lr = Cells(Rows.Count, 1).End(xlUp).Row

    lc = Cells(1, Columns.Count).End(xlToLeft).Column

    Open pathTxt For Output As #1

        For i = 1 To lr

            temp = i - 1 & ":"

            For j = 1 To lc

                temp = temp & Cells(i, j) & ";"

            Next j

            Print #1, temp

        Next i

    Close #1

    appWinRar = "C:\Program Files (x86)\WinRAR\WinRAR.exe a -ep1 -df"

    rarName = ActiveWorkbook.Path & "\" & "09" & Format(nameTxt, "000") & ".zip"

    str = appWinRar & " """ & rarName & """ """ & pathTxt & """ "

    Shell str, vbHide

    ActiveWindow.Close False

End Sub
[/vba]

Может подскажите сделать элегантно, как весь ваш код)


Сообщение отредактировал skobelev - Среда, 16.11.2016, 08:43
 
Ответить
СообщениеManyasha, В принципе очень грубо, но добавил "1" в ваш код)))
[vba]
Код
Sub csvToTxt()

    Dim pathTxt$, temp$, nameTxt$

    Dim rarName$, appWinRar$, str$

    Dim lr&, lc&, i&, j&

    Range("D1").Select

    ActiveCell.FormulaR1C1 = "1"

    Selection.AutoFill Destination:=Range("D1:3600"), Type:=xlFillDefault

    nameTxt = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)

    pathTxt = ActiveWorkbook.Path & "\" & "09" & Format(nameTxt, "000") & ".txt"

    lr = Cells(Rows.Count, 1).End(xlUp).Row

    lc = Cells(1, Columns.Count).End(xlToLeft).Column

    Open pathTxt For Output As #1

        For i = 1 To lr

            temp = i - 1 & ":"

            For j = 1 To lc

                temp = temp & Cells(i, j) & ";"

            Next j

            Print #1, temp

        Next i

    Close #1

    appWinRar = "C:\Program Files (x86)\WinRAR\WinRAR.exe a -ep1 -df"

    rarName = ActiveWorkbook.Path & "\" & "09" & Format(nameTxt, "000") & ".zip"

    str = appWinRar & " """ & rarName & """ """ & pathTxt & """ "

    Shell str, vbHide

    ActiveWindow.Close False

End Sub
[/vba]

Может подскажите сделать элегантно, как весь ваш код)

Автор - skobelev
Дата добавления - 16.11.2016 в 08:14
Manyasha Дата: Среда, 16.11.2016, 11:20 | Сообщение № 15
Группа: Модераторы
Ранг: Старожил
Сообщений: 1582
Репутация: 659 ±
Замечаний: 0% ±

Excel 2007, 2010
Таблицу с именами файлов взяла у Ярослава.
[vba]
Код
Sub csvToTxt()
    Application.ScreenUpdating = False
    Dim pathTxt$, temp$
    Dim rarName$, appWinRar$, str$
    Dim lr&, lc&, i&, j&, r&
    Dim wbCsv As Workbook, sh As Worksheet
    Set sh = ThisWorkbook.Sheets(1)
    appWinRar = "C:\Program Files\WinRAR\WinRAR.exe a -ep1 -df"
    With sh
        For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            Set wb = Workbooks.Open(.Cells(r, 1))
            pathTxt = .Cells(r, 2)
            With wb.Sheets(1)
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
                lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
                Open pathTxt For Output As #1
                    For i = 1 To lr
                        temp = i - 1 & ":"
                        For j = 1 To lc
                            temp = temp & .Cells(i, j) & ";"
                        Next j
                        temp = temp & "1;"
                        Print #1, temp
                    Next i
                Close #1
                rarName = sh.Cells(r, 3)
                str = appWinRar & " """ & rarName & """ """ & pathTxt & """ "
                Shell str, vbHide
            End With
            wb.Close False
        Next r
    End With
    Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: 6655888.xlsm(21Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеТаблицу с именами файлов взяла у Ярослава.
[vba]
Код
Sub csvToTxt()
    Application.ScreenUpdating = False
    Dim pathTxt$, temp$
    Dim rarName$, appWinRar$, str$
    Dim lr&, lc&, i&, j&, r&
    Dim wbCsv As Workbook, sh As Worksheet
    Set sh = ThisWorkbook.Sheets(1)
    appWinRar = "C:\Program Files\WinRAR\WinRAR.exe a -ep1 -df"
    With sh
        For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            Set wb = Workbooks.Open(.Cells(r, 1))
            pathTxt = .Cells(r, 2)
            With wb.Sheets(1)
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
                lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
                Open pathTxt For Output As #1
                    For i = 1 To lr
                        temp = i - 1 & ":"
                        For j = 1 To lc
                            temp = temp & .Cells(i, j) & ";"
                        Next j
                        temp = temp & "1;"
                        Print #1, temp
                    Next i
                Close #1
                rarName = sh.Cells(r, 3)
                str = appWinRar & " """ & rarName & """ """ & pathTxt & """ "
                Shell str, vbHide
            End With
            wb.Close False
        Next r
    End With
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 16.11.2016 в 11:20
skobelev Дата: Пятница, 18.11.2016, 06:06 | Сообщение № 16
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, Марина, спасибо!

Создам еще одну тему, задачка усложнилась)
 
Ответить
СообщениеManyasha, Марина, спасибо!

Создам еще одну тему, задачка усложнилась)

Автор - skobelev
Дата добавления - 18.11.2016 в 06:06
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перевод csv в txt с добавлением данных и упаковывание в zip (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!