Перенос данных из определенной ячейки в текстовый файл - Мир MS Excel

Регистрация

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

= Мир MS Excel/Перенос данных из определенной ячейки в текстовый файл - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных из определенной ячейки в текстовый файл (Макросы/Sub)

Перенос данных из определенной ячейки в текстовый файл

Дата: Вторник, 31.03.2015, 09:36 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Добрый день!
Попытаюсь описать задачу понятно.
Имею экселевский файл с списком рекламы 28.03.2015.xls. В колонке название блока указан номер блока. Необходимо чтобы скрипт создал тестовый файл с именем номера блока взятого из колонки с номером блока и расширением .air, далее в файле вставлял в этот файл в первую строку строчку "comment 0 " без кавычек и номер блока, а далее брал ID ролика и в каждую строку добавляя перед ID "movie 0:00:00.00 R:", а после ID добавлял ".avi", чтоб получилось так :

и так с каждым блоком новый файл.
В файле 40 блоков и должно получиться 40 текстовых файлов с расширением .air
Подскажите можно это скриптом реализовать?
1.rar прилагаю с иходником Exel 28.03.2015.xls и результат как должно получиться 01-РЕК.air

К сообщению приложен файл: 28.03.2015.xls (28.0 Kb) · 01-.air (0.1 Kb)

Сообщение отредактировал d22cva - Вторник, 31.03.2015, 09:37

Ответить

Дата: Вторник, 31.03.2015, 10:52 | Сообщение № 2

Группа: Авторы

Ранг: Ветеран

Сообщений: 903

Репутация: 290 ±

Замечаний: 0% ±

Excel 2013

d22cva, здравствуйте.

Уточните по поводу имён результирующих файлов.

Цитата d22cva, 31.03.2015 в 09:36, в сообщении № 1

тестовый файл с именем номера блока

Цитата d22cva, 31.03.2015 в 09:36, в сообщении № 1

результат как должно получиться 01-РЕК.air

1). Важно ли наличие ноля перед цифрой номера блока, если номер блока меньше 10-ти?
2). Должен ли быть дефис в имени?
3). Должна ли стоять "РЕК" в названии файла? На каком языке?

Роман, Москва, voronov_rv@mail.ru
Яндекс-Деньги: 41001312674279

Ответить

Дата: Вторник, 31.03.2015, 11:06 | Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Цитата Rioran, 31.03.2015 в 10:52, в сообщении № 2

Уточните по поводу имён результирующих файлов.

Цитата d22cva, 31.03.2015 в 09:36, в сообщении № 1
тестовый файл с именем номера блока

Цитата d22cva, 31.03.2015 в 09:36, в сообщении № 1
результат как должно получиться 01-РЕК.air

1). Важно ли наличие ноля перед цифрой номера блока, если номер блока меньше 10-ти?
2). Должен ли быть дефис в имени?
3). Должна ли стоять "РЕК" в названии файла? На каком языке?

Результирующий файл должен содержать в имени файла хотя бы номер блока, все остальное не обязательно.Пример, 1.air
1) Полем вы подразумеваете 0, то есть 01? Если да то это не имеет значения, отлично будет если будет просто 1.
2) Дефис не обязателен , можно вообще без него
3) Рек тоже не обязательно, если давать его то можно на английском

Ответить

Дата: Вторник, 31.03.2015, 11:19 | Сообщение № 4

Группа: Авторы

Ранг: Ветеран

Сообщений: 903

Репутация: 290 ±

Замечаний: 0% ±

Excel 2013

d22cva, приглашаю протестировать, файл с кнопкой во вложении.

Сохраните файл в новой папке в любом месте на компьютере. Откройте файл, разрешите макросы. По нажатию кнопки в папке с файлом будут созданы текстовые файлы.

[vba]

Код

Sub Print_Airs()

'Author:    Roman "Rioran" Voronov
'Date:      the 31-st of March, 2015
'Feedback:  voronov_rv@mail.ru

'Программа для составления .air файлов в той же папке, где сохранена эта книга Excel

Dim sPath As String
Dim PS As String

Dim Check As Boolean
Dim Block As String
Dim StrX As String
Dim RowX As Long
Dim i&, j&, k&

PS = Application.PathSeparator

sPath = ThisWorkbook.Path
If Right(sPath, 1) <> PS Then sPath = sPath & PS

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

For i = 5 To RowX
      Block = Cells(i, 1).Value
      If Block <> "" Then
          StrX = "comment 0 " & Block
          Do While Cells(i, 4).Value <> 0
              StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
              i = i + 1
          Loop
          Check = SaveTXTfile(sPath & Block & "-PEK.air", StrX)
      End If
Next i

MsgBox "Done"

End Function

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
'Функция сохранения файла, спасибо => http://excelvba.ru/code/txt

      Dim fso, ts

      On Error Resume Next
      Err.Clear

      Set fso = CreateObject("scripting.filesystemobject")
      Set ts = fso.CreateTextFile(filename, True)
      ts.Write txt
      ts.Close
      SaveTXTfile = Err = 0

      Set ts = Nothing
      Set fso = Nothing
End Function

[/vba]

d22cva, приглашаю протестировать, файл с кнопкой во вложении.

Сохраните файл в новой папке в любом месте на компьютере. Откройте файл, разрешите макросы. По нажатию кнопки в папке с файлом будут созданы текстовые файлы.

[vba]

Код

Sub Print_Airs()

'Author:    Roman "Rioran" Voronov
'Date:      the 31-st of March, 2015
'Feedback:  voronov_rv@mail.ru

'Программа для составления .air файлов в той же папке, где сохранена эта книга Excel

Dim sPath As String
Dim PS As String

Dim Check As Boolean
Dim Block As String
Dim StrX As String
Dim RowX As Long
Dim i&, j&, k&

PS = Application.PathSeparator

sPath = ThisWorkbook.Path
If Right(sPath, 1) <> PS Then sPath = sPath & PS

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

For i = 5 To RowX
      Block = Cells(i, 1).Value
      If Block <> "" Then
          StrX = "comment 0 " & Block
          Do While Cells(i, 4).Value <> 0
              StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
              i = i + 1
          Loop
          Check = SaveTXTfile(sPath & Block & "-PEK.air", StrX)
      End If
Next i

MsgBox "Done"

End Function

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
'Функция сохранения файла, спасибо => http://excelvba.ru/code/txt

      Dim fso, ts

      On Error Resume Next
      Err.Clear

      Set fso = CreateObject("scripting.filesystemobject")
      Set ts = fso.CreateTextFile(filename, True)
      ts.Write txt
      ts.Close
      SaveTXTfile = Err = 0

      Set ts = Nothing
      Set fso = Nothing
End Function

[/vba]Rioran

К сообщению приложен файл: 28.03.2015.xlsb (21.4 Kb)

Роман, Москва, voronov_rv@mail.ru
Яндекс-Деньги: 41001312674279

Сообщение отредактировал Rioran - Вторник, 31.03.2015, 11:28

Ответить

Сообщениеd22cva, приглашаю протестировать, файл с кнопкой во вложении.

Сохраните файл в новой папке в любом месте на компьютере. Откройте файл, разрешите макросы. По нажатию кнопки в папке с файлом будут созданы текстовые файлы.

[vba]

Код

Sub Print_Airs()

'Author:    Roman "Rioran" Voronov
'Date:      the 31-st of March, 2015
'Feedback:  voronov_rv@mail.ru

'Программа для составления .air файлов в той же папке, где сохранена эта книга Excel

Dim sPath As String
Dim PS As String

Dim Check As Boolean
Dim Block As String
Dim StrX As String
Dim RowX As Long
Dim i&, j&, k&

PS = Application.PathSeparator

sPath = ThisWorkbook.Path
If Right(sPath, 1) <> PS Then sPath = sPath & PS

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

For i = 5 To RowX
      Block = Cells(i, 1).Value
      If Block <> "" Then
          StrX = "comment 0 " & Block
          Do While Cells(i, 4).Value <> 0
              StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
              i = i + 1
          Loop
          Check = SaveTXTfile(sPath & Block & "-PEK.air", StrX)
      End If
Next i

MsgBox "Done"

End Function

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
'Функция сохранения файла, спасибо => http://excelvba.ru/code/txt

      Dim fso, ts

      On Error Resume Next
      Err.Clear

      Set fso = CreateObject("scripting.filesystemobject")
      Set ts = fso.CreateTextFile(filename, True)
      ts.Write txt
      ts.Close
      SaveTXTfile = Err = 0

      Set ts = Nothing
      Set fso = Nothing
End Function

[/vba]

Автор - Rioran
Дата добавления - 31.03.2015 в 11:19

Дата: Вторник, 31.03.2015, 12:12 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Rioran, к сожалению не создает. Выдается сообщение Compile error: Expected End Sub

К сообщению приложен файл: 6894461.jpg (28.1 Kb)

Ответить

Дата: Вторник, 31.03.2015, 12:18 | Сообщение № 6

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

Ну так замените первое End Function на End sub

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Дата: Вторник, 31.03.2015, 12:59 | Сообщение № 7

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Rioran, KuklP, Благодарю! А как сделать чтоб рядом с экселевским файлом создавалась папка и в ней уже создавались все мои файлы? А папке присуждалось бы имя из ячейки А2 с 9 по 18 символ, т.е. там текст "на дату 28.03.2015 бла бла бла бла" , а папка бы создавалась с именем 28.03.2015?

Ответить

Дата: Вторник, 31.03.2015, 13:28 | Сообщение № 8

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

[vba]

Код

Sub Print_Airs()

'Author:    Roman "Rioran" Voronov
'Date:      the 31-st of March, 2015
'Feedback:  voronov_rv@mail.ru

Dim sPath As String
Dim PS As String

Dim Check As Boolean
Dim Block As String
Dim StrX As String
Dim RowX As Long
Dim i&, j&, k&

PS = Application.PathSeparator

sPath = ThisWorkbook.Path
If Right(sPath, 1) <> PS Then sPath = sPath & PS
sPath = sPath & Right$(Trim$([a2]), 10) ' & PS
CreateObject("Shell.Application").Namespace(Left(sPath, 3)).NewFolder (sPath)
RowX = Cells(Rows.Count, 1).End(xlUp).Row

For i = 5 To RowX
     Block = Cells(i, 1).Value
     If Block <> "" Then
         StrX = "comment 0 " & Block
         Do While Cells(i, 4).Value <> 0
             StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
             i = i + 1
         Loop
         Check = SaveTXTfile(sPath & PS & Block & "-PEK.air", StrX)
     End If
Next i

MsgBox "Done"

End Sub

[/vba]

К сообщению приложен файл: 8103122.xlsb (23.1 Kb)

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Дата: Вторник, 31.03.2015, 13:44 | Сообщение № 9

Группа: Авторы

Ранг: Ветеран

Сообщений: 903

Репутация: 290 ±

Замечаний: 0% ±

Excel 2013

d22cva, исправил опечатку, добавил создание папки:

[vba]

Код

Sub Print_Airs()

'Author:    Roman "Rioran" Voronov
'Date:      the 31-st of March, 2015
'Feedback:  voronov_rv@mail.ru

'Программа для составления .air файлов в той же папке, где сохранена эта книга Excel

Dim sFolder As String
Dim sPath As String
Dim PS As String

Dim Check As Boolean
Dim Block As String
Dim StrX As String
Dim RowX As Long
Dim i&, j&, k&

PS = Application.PathSeparator

sPath = ThisWorkbook.Path
If Right(sPath, 1) <> PS Then sPath = sPath & PS

sFolder = Cells(2, 1).Value
sFolder = Left(Right(sFolder, Len(sFolder) - 8), 10)
If InStr(1, sFolder, " ") Then sFolder = Left(sFolder, InStr(1, sFolder, " ") - 1)
sFolder = sPath & sFolder

MkDir (sFolder)

sFolder = sFolder & PS
RowX = Cells(Rows.Count, 1).End(xlUp).Row

For i = 5 To RowX
     Block = Cells(i, 1).Value
     If Block <> "" Then
         StrX = "comment 0 " & Block
         Do While Cells(i, 4).Value <> 0
             StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
             i = i + 1
         Loop
         Check = SaveTXTfile(sFolder & Block & "-PEK.air", StrX)
     End If
Next i

MsgBox "Done"

End Sub

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
'Функция сохранения файла, спасибо => http://excelvba.ru/code/txt

     Dim fso, ts

     On Error Resume Next
     Err.Clear

     Set fso = CreateObject("scripting.filesystemobject")
     Set ts = fso.CreateTextFile(filename, True)
     ts.Write txt
     ts.Close
     SaveTXTfile = Err = 0

     Set ts = Nothing
     Set fso = Nothing
End Function

[/vba]

К сообщению приложен файл: Air_Printer.xlsb (26.6 Kb)

Роман, Москва, voronov_rv@mail.ru
Яндекс-Деньги: 41001312674279

Ответить

Сообщениеd22cva, исправил опечатку, добавил создание папки:

[vba]

Код

Sub Print_Airs()

'Author:    Roman "Rioran" Voronov
'Date:      the 31-st of March, 2015
'Feedback:  voronov_rv@mail.ru

'Программа для составления .air файлов в той же папке, где сохранена эта книга Excel

Dim sFolder As String
Dim sPath As String
Dim PS As String

Dim Check As Boolean
Dim Block As String
Dim StrX As String
Dim RowX As Long
Dim i&, j&, k&

PS = Application.PathSeparator

sPath = ThisWorkbook.Path
If Right(sPath, 1) <> PS Then sPath = sPath & PS

sFolder = Cells(2, 1).Value
sFolder = Left(Right(sFolder, Len(sFolder) - 8), 10)
If InStr(1, sFolder, " ") Then sFolder = Left(sFolder, InStr(1, sFolder, " ") - 1)
sFolder = sPath & sFolder

MkDir (sFolder)

sFolder = sFolder & PS
RowX = Cells(Rows.Count, 1).End(xlUp).Row

For i = 5 To RowX
     Block = Cells(i, 1).Value
     If Block <> "" Then
         StrX = "comment 0 " & Block
         Do While Cells(i, 4).Value <> 0
             StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
             i = i + 1
         Loop
         Check = SaveTXTfile(sFolder & Block & "-PEK.air", StrX)
     End If
Next i

MsgBox "Done"

End Sub

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
'Функция сохранения файла, спасибо => http://excelvba.ru/code/txt

     Dim fso, ts

     On Error Resume Next
     Err.Clear

     Set fso = CreateObject("scripting.filesystemobject")
     Set ts = fso.CreateTextFile(filename, True)
     ts.Write txt
     ts.Close
     SaveTXTfile = Err = 0

     Set ts = Nothing
     Set fso = Nothing
End Function

[/vba]

Автор - Rioran
Дата добавления - 31.03.2015 в 13:44

Дата: Вторник, 31.03.2015, 13:48 | Сообщение № 10

Группа: Авторы

Ранг: Ветеран

Сообщений: 903

Репутация: 290 ±

Замечаний: 0% ±

Excel 2013

KuklP, добрый день, у Вас интересный вариант.

При тестировании если в ячейке А2 стоит строка: "на дату 1.03.2015 ok?" Ваш код выдает ошибку метода NewFolder. Плюс не обрезается строка в случае первых 9-ти чисел месяца.

Роман, Москва, voronov_rv@mail.ru
Яндекс-Деньги: 41001312674279

Ответить

Дата: Вторник, 31.03.2015, 13:54 | Сообщение № 11

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

Цитата d22cva, 31.03.2015 в 12:59, в сообщении № 7

А папке присуждалось бы имя из ячейки А2 с 9 по 18 символ

Да делал тупо по примеру, тогда уж:
[vba]

Код

sPath = sPath & Mid$([a2], 9, 10)

[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Дата: Вторник, 31.03.2015, 14:44 | Сообщение № 12

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Rioran, KuklP, спасибо! теперь все идеально! Пару дней потестирую и отпишусь полным описанием решения

Ответить

Дата: Среда, 01.04.2015, 11:08 | Сообщение № 13

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

KuklP, Rioran, Подскажите, проблема в сортировке файлов, как сделать чтоб в имя файла от 1 до 9 подставлялся 0 перед числом чтоб выглядело так 01-PEK.air...09-PEK.air ?

Ответить

Дата: Среда, 01.04.2015, 14:40 | Сообщение № 14

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198

Репутация: 898 ±

Замечаний: 0% ±

Excel 2010, 2016

d22cva, здравствуйте. Перед вызовом функции сохранения файла, можно проверить длину переменно Block[vba]

Код

Block = IIf(Len(Block) = 1, "0" & Block, Block)'Добавила
Check = SaveTXTfile(sFolder & Block & "-PEK.air", StrX)

[/vba]
[p.s.]Код смотрела у Романа: сообщение 9

ЯД: 410013299366744 WM: R193491431804

Ответить

Дата: Среда, 01.04.2015, 15:02 | Сообщение № 15

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

Можно проще:
[vba]

Код

     For i = 5 To RowX
         If Cells(i, 1).Value <> "" Then
             Block = Format(Cells(i, 1).Value, "00")
             StrX = "comment 0 " & Block
             Do While Cells(i, 4).Value <> 0
                 StrX = StrX & vbNewLine & "movie 0:00:00.00 R:" & Cells(i, 4).Value & ".avi"
                 i = i + 1
             Loop
             Check = SaveTXTfile(sPath & PS & Block & "-PEK.air", StrX)
         End If
     Next i

[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных из определенной ячейки в текстовый файл (Макросы/Sub)

Страница 1 из 1
1

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