Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Главное меню

Импорт макроса в книгу из командной строки

Автор vadick, 09.11.2011, 11:09

« назад - далее »

vadick

Доброго времени суток, подскажите, возможно ли внедрение макроса в файл xls из командной строки?

exceleved

Можно из командной строки запустить VBS скрипт, который сделает это.
А зачем?

vadick

Проблема такова, делается файл, в нем зашит макрос. При работе с файлом на КПК через Pocket Excel, при сохранении макрос зашитый в файл - тупо грохается. Ну не поддерживает Pocket Excel макросы. Потом это файло обрабатывается автоматом, программа которая выполняет автоматически  макрос  уже на компе, может запускать только макросы зашитые в файл.

По поводу vbs, можно поподробнее?

exceleved

Может, лучше держать макрос в надстройке Excel или в Личной книге макросов (personal.xls)?

vadick

Не выход. Схема такова, работает разборщик почты, получает архивы, разархивируем, список передается на выполнение макроса, отрабатывает макрос, с каждого листа получаем dbf. Отработка макроса возможна только если он в каждой книге есть. Посему, ни надстройка, ни личная книга макросов не подойдут.

vadick

Победил. Спасибо за ответы :).
Вот это счастье сохраняем в текстовый файл с расширением vbs.
По итогу в файле появляется макрос ЭтаКнига.CreateDBF
Вот его-то мы и запускаем для обработки файла.


DBF
Sub DBF()
    Dim oExcel
    Set oExcel = CreateObject("Excel.Application")
    oExcel.Application.Workbooks.Open ("D:\Zakaz\tpdon01\08.11.2011\1 рыбалко гп факт.XLS")
    oExcel.DisplayAlerts = False
    oExcel.Application.DefaultFilePath = "D:\Zakaz\tpdon01\08.11.2011\"
    Code = "Sub CreateDBF()" & vbCrLf
    Code = Code & "'Отрубаем предупреждения. Иначе при сохранении будет спрашивать вопросы про потерю форматирования" & vbCrLf
    Code = Code & "Application.DisplayAlerts = False" & vbCrLf
    Code = Code & "'Открываем цикл для обработки каждого листа. Цикл отрабатывает до количества листов (Sheets.Count)" & vbCrLf
    Code = Code & "    Dim Sum As Double, Count As Integer" & vbCrLf
    Code = Code & "    Sum = 0" & vbCrLf
    Code = Code & "    For Count = 1 To Sheets.Count" & vbCrLf
    Code = Code & "    Sum = Sum + 1" & vbCrLf
    Code = Code & "'Делаем проверку (1). Если сумма заказа в ячейке А1 не равна нулю - запускается следующая проверка" & vbCrLf
    Code = Code & "'Нужна для того, чтобы не обрабатывался лист без заказа" & vbCrLf
    Code = Code & "    If Sheets(Sum).Cells(1, 1).Value <> ""0"" Then" & vbCrLf
    Code = Code & "'Еще одна проверка (2). Если - ячейка А1 пустая то не запускается обработка листа." & vbCrLf
    Code = Code & "'Нужна для листа на котором есть служебная инфа и нет заказа" & vbCrLf
    Code = Code & "    If Sheets(Sum).Cells(1, 1).Value <> """" Then" & vbCrLf
    Code = Code & "'Активируем лист" & vbCrLf
    Code = Code & "    Sheets(Sum).Activate" & vbCrLf
    Code = Code & "'Блок удаления ненужных строк и столбцов" & vbCrLf
    Code = Code & "    Rows(""1:1"").Select" & vbCrLf
    Code = Code & "    Selection.Delete Shift:=xlUp" & vbCrLf
    Code = Code & "    Columns(""A:A"").Select" & vbCrLf
    Code = Code & "    Selection.Delete Shift:=xlToLeft" & vbCrLf
    Code = Code & "    Columns(""B:B"").Select" & vbCrLf
    Code = Code & "    Selection.Delete Shift:=xlToLeft" & vbCrLf
    Code = Code & "    Columns(""B:B"").Select" & vbCrLf
    Code = Code & "    Selection.Delete Shift:=xlToLeft" & vbCrLf
    Code = Code & "    Columns(""C:C"").Select" & vbCrLf
    Code = Code & "    Selection.Delete Shift:=xlToLeft" & vbCrLf
    Code = Code & "'Блок удаления позиций с нулевым значением заказа" & vbCrLf
    Code = Code & "    Dim sSubStr As String 'выставляем символ по которому будет искать строки" & vbCrLf
    Code = Code & "    Dim lCol As Long 'номер столбца по которому искать символ" & vbCrLf
    Code = Code & "    Dim lLastRow As Long, li As Long" & vbCrLf
    Code = Code & "    sSubStr = ""0""" & vbCrLf
    Code = Code & "    lCol = ""1""" & vbCrLf
    Code = Code & "    If lCol = 0 Then Exit Sub" & vbCrLf
    Code = Code & "    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count" & vbCrLf
    Code = Code & "    Application.ScreenUpdating = 1" & vbCrLf
    Code = Code & "    For li = lLastRow To 1 Step -1" & vbCrLf
    Code = Code & "        If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete" & vbCrLf
    Code = Code & "    Next li" & vbCrLf
    Code = Code & "    Application.ScreenUpdating = 1" & vbCrLf
    Code = Code & "'Блок удаления пустых строк" & vbCrLf
    Code = Code & "    Dim sSubStr1 As String 'выставляем символ по которому будет искать строки" & vbCrLf
    Code = Code & "    Dim lCol1 As Long 'номер столбца по которому искать символ" & vbCrLf
    Code = Code & "    Dim lLastRow1 As Long, li1 As Long" & vbCrLf
    Code = Code & "    sSubStr1 = """"" & vbCrLf
    Code = Code & "    lCol1 = ""1""" & vbCrLf
    Code = Code & "    If lCol1 = 0 Then Exit Sub" & vbCrLf
    Code = Code & "    lLastRow1 = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count" & vbCrLf
    Code = Code & "    Application.ScreenUpdating = 1" & vbCrLf
    Code = Code & "    For li1 = lLastRow1 To 1 Step -1" & vbCrLf
    Code = Code & "        If CStr(Cells(li1, lCol1)) = sSubStr1 Then Rows(li1).Delete" & vbCrLf
    Code = Code & "    Next li1" & vbCrLf
    Code = Code & "    Application.ScreenUpdating = 1" & vbCrLf
    Code = Code & "'Ставим курсор в ячейку А1. Иначе не сохраняет, поскольку выделен столбец С." & vbCrLf
    Code = Code & "    Range(""A1:A1"").Select" & vbCrLf
    Code = Code & "'Блок сохранения листа в dbf. Сохраняет по типу: имя исходного файла + имя листа" & vbCrLf
    Code = Code & "'Сохранение происходит в ту же папку что и исходный файл" & vbCrLf
    Code = Code & "    ActiveWorkbook.SaveAs Filename:= _" & vbCrLf
    Code = Code & "    ThisWorkbook.Path & ""\"" & ActiveWorkbook.Name & ""_"" & ActiveSheet.Name & "".dbf"", FileFormat:=xlDBF4 _" & vbCrLf
    Code = Code & "    , CreateBackup:=False" & vbCrLf
    Code = Code & "'Закрываем проверку (2)" & vbCrLf
    Code = Code & "    End If" & vbCrLf
    Code = Code & "'Закрываем проверку (1)" & vbCrLf
    Code = Code & "    End If" & vbCrLf
    Code = Code & "'Закрываем цикл" & vbCrLf
    Code = Code & "    Next Count" & vbCrLf
    Code = Code & "'Закрываем Excel, иногда висит в памяти" & vbCrLf
    Code = Code & "    Application.Quit" & vbCrLf
    Code = Code & "End Sub" & vbCrLf
    With oExcel.ActiveWorkbook.VBProject. _
        VBComponents(1).CodeModule
        NextLine = .CountOfLines + 1
        .InsertLines NextLine, Code
    End With
    oExcel.ActiveWorkbook.Save
    oExcel.Quit
End Sub