Visual Basic - доработать макрос.

Pashtet · 24.12.15

Народ, кто знаком с Visual Basic, в плане написания макросов для Exel - помогите!
Суть - есть екселевский файлик + макрос в нем. Функция макроса, по запуску, формирует фаил с разделителями на основе данных из таблицы. Затем запрашивает, куда сохранить.
Нужно, что бы после того, как сохранил фаил, автоматом, в той же папке создавал пустой фаил с заранее заданным именем (фаил флаг).
Чет, вчера пошарил по инету, но так и не нашел команды создания файла без диалогового окна.
Сам фаил лежит тут
http://fs.atol.ru/_layouts/15/atol....=5604d961-4c72-4c35-888e-bb700e3f0561&webUrl=

Текст макроса.

Sub SaveFile()
Dim Data ' массив куда скидывается строка Номенклатуры
Dim r As Long ' Номер строки
Dim Count_Nom As Long
Dim Filt As String ' Фильтр файла
Dim FileName As Variant ' Путь к файлу загрузки плюс его имя
Dim Count_Ost As Long 'номер нижней заполненой строки в Остатках
Dim oo As Long 'текущая строка справочника Остатков

Count_Nom = Sheets("Номенклатура").Cells(Sheets("Номенклатура").Rows.Count, 2).End(xlUp).Row
Filt = "(*.txt),*.txt," & "(*.sprt),*.sprt," & "(*.*),*.*"
FileName = Application.GetSaveAsFilename("in", Filt, 0, "Сохраните файл загрузки")
If FileName = False Then
MsgBox "Вы отменили сохранение файла загрузки"
Exit Sub
End If

Open FileName For Output As #1

Data = "##@@&&" & Chr(13) & Chr(10) & "#" & Chr(13) & Chr(10) & _
"$$$DELETEALLWARES" & Chr(13) & Chr(10) & "$$$ADDQUANTITY" & Chr(13) & Chr(10)
Print #1, Data;

r = 3
Do While r <= Count_Nom
If (Sheets("Номенклатура").Cells(r, 2) <> "") And (Sheets("Номенклатура").Cells(r, 4) = 0) Then
Data = Sheets("Номенклатура").Cells(r, 2).Value & ";" '1
Data = Data & Sheets("Номенклатура").Cells(r, 7) & ";" '2
Data = Data & Sheets("Номенклатура").Cells(r, 5) & ";" '3
Data = Data & Sheets("Номенклатура").Cells(r, 5) & ";" '4
Data = Data & Sheets("Номенклатура").Cells(r, 10) & ";" '5
Data = Data & Sheets("Номенклатура").Cells(r, 8) & ";" '6
Data = Data & "0;0;;0;" '7-10
Data = Data & Sheets("Номенклатура").Cells(r, 12) & ";" '11
Data = Data & "0;0;1;;" '12-15
Data = Data & Sheets("Номенклатура").Cells(r, 3) & ";" '16
Data = Data & Sheets("Номенклатура").Cells(r, 4) & ";" '17
Data = Data & "0;0;;;;" '18-22
Data = Data & Sheets("Номенклатура").Cells(r, 11) & ";" & Chr(13) & Chr(10) '23
Print #1, Data;
End If
r = r + 1
Loop

r = 3
Do While r <= Count_Nom
If (Sheets("Номенклатура").Cells(r, 2) <> "") And (Sheets("Номенклатура").Cells(r, 4) = 1) Then
Data = Sheets("Номенклатура").Cells(r, 2).Value & ";" '1
Data = Data & Sheets("Номенклатура").Cells(r, 7) & ";" '2
Data = Data & Sheets("Номенклатура").Cells(r, 5) & ";" '3
Data = Data & Sheets("Номенклатура").Cells(r, 5) & ";" '4
Data = Data & Sheets("Номенклатура").Cells(r, 10) & ";" '5
Data = Data & Sheets("Номенклатура").Cells(r, 8) & ";" '6
Data = Data & "0;0;;0;" '7-10
Data = Data & Sheets("Номенклатура").Cells(r, 12) & ";" '11
Data = Data & "0;0;1;" '12-14
Data = Data & Sheets("Номенклатура").Cells(r, 6) & ";" '15
Data = Data & Sheets("Номенклатура").Cells(r, 3) & ";" '16
Data = Data & Sheets("Номенклатура").Cells(r, 4) & ";" '17
Data = Data & "0;0;;;;" '18-22
Data = Data & Sheets("Номенклатура").Cells(r, 11) & ";" '23
Data = Data & ";;" '24-25
Data = Data & Sheets("Номенклатура").Cells(r, 13) & ";" & Chr(13) & Chr(10) '26 для алкоголя
Print #1, Data;
End If
r = r + 1
Loop

Data = "$$$REPLACEASPECTREMAINS"
Print #1, Data;
Count_Ost = Sheets("Остатки").Cells(Sheets("Остатки").Rows.Count, 2).End(xlUp).Row
For oo = 3 To Count_Ost
If Sheets("Остатки").Cells(oo, 4) <> "" Then
Data = Chr(13) & Chr(10)
Data = Data & Sheets("Остатки").Cells(oo, 2) & ";" '1 Код
Data = Data & Sheets("Остатки").Cells(oo, 6) & ";" '2 Остаток
Data = Data & Sheets("Остатки").Cells(oo, 4) & ";" '3 Коды значений разрезов
Data = Data & Sheets("Остатки").Cells(oo, 5) & ";" '4 Цена
Data = Data & ";;" '5-6
Print #1, Data;
End If
Next

Close #1
MsgBox ("Файл выгрузки ''" & FileName & "'' создан. ")
End Sub
Нажмите, чтобы раскрыть...

gerodoth · 24.12.15

очевидно после Close #1
из строки FileName нужно получить папку
fso.GetParentFolderName(FileName)
из него получить желаемое имя флага, что-то типа
FlagName = fso.GetParentFolderName(FileName) & "Flag.Ext"
а потом записать файл на диск
Dim fso, f1
Set fso = CreateObject("Scripting.FileSystemObject")
Set f1 = fso.CreateTextFile(FlagName, True)

но я на вбс писать не умею

Вход / Регистрация

Visual Basic - доработать макрос.

Pashtet Активный участник

gerodoth Активный участник

Вход / Регистрация

Волгоградский форум

Пользователи

Visual Basic - доработать макрос.

Pashtet Активный участник

gerodoth Активный участник