Страницы: 1
RSS
Сохранить вкладки книги в отдельные файлы, разорвать связи с PQ и выложить по ссылке
 
Добрый вечер, форумчане.
Периодически приходится совершать одни и те же действия - после обновления файла с помощью PQ разбиваю вкладки в отдельные файлы (с помощью макроса), вручную каждый сохраняю с определённым именем в двоичном формате, чтобы меньше весил, архивирую (файл выкладывается в общий доступ, чтобы не фильтровали, не создавали новые листы, утяжеляя при этом файл) и выкладываю на ресурс.
Можно ли этот процесс автоматизировать? Название созданного файла = название вкладки + сегодняшняя дата? Реализовать разрыв связи c PQ также не удалось, не хочет работать
Код
ActiveWorkbook.Queries("Тест").Delete
Макрос автоматической загрузки по указанной ссылке?
 
Доброе время суток
Цитата
Maayun написал:
Реализовать разрыв связи c PQ также не удалось, не хочет работать
А что сообщает - не уж то молча игнорирует? У меня в вашем файле отработало
Код
Public Sub delQueries()
    Dim pQuery As WorkbookQuery
    For Each pQuery In ActiveWorkbook.Queries
        pQuery.Delete
    Next
End Sub
 
Андрей VG, если запускать с
Код
ActiveWorkbook.Queries("Тест").Delete

то ошибка "Объект не поддерживает этот метод" и выделяют всю строку жёлтым.

Если ваш вариант, то "User-defined type not defined".

Зависит от версии Excel? У меня 2013

 
Код
Sub delConnections()
    Dim Connection As WorkbookConnection
    For Each Connection In ActiveWorkbook.Connections
        Connection.Delete
    Next
End Sub
Попробуйте вот такой вариант. В Excel 2013 нет объектов Queries.
Изменено: ctacon - 20.09.2019 05:30:23
 
ctacon, всё верно - работает.
Не подскажете, как быть с архивацией и выкладкой по заданному пути? в текущем макросе архивирует, но при открытии архива ругается, что формат файла не соответствует его разрешению
 
Цитата
Maayun написал:
формат файла не соответствует его разрешению
И не должен. Файл с кодом у Вас в формате .xlsm, а для самой копии Вы почему-то указываете формат .xls:
FileNameXls = DefPath & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & strDate & ".xls"
ThisWorkbook.SaveCopyAs FileNameXls
В данном случае надо тогда не как копию сохранять, а при помощи метода именно SaveAs или все же оставить уже реальное расширение.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий, спасибо - пофиксила.
Подскажите, можно ли задать название архива, исходя из названия вкладки: в моем основном файле их несколько,макросом выношу в отдельные файлы и надо,чтобы они заархивировались согласно названия вкладки.
 
Maayun, на будущее: то, что Вы называете вкладками, в Excel принято называть листами ))
 
Юрий М,  :D ой, что-то я по аналогии с браузером называю. Конечно, листы имею в виду :oops:  
 
Цитата
Maayun написал:
исходя из названия вкладки
не совсем понятно куда это название прилепить в приложенном коде. Так же непонятно что делать, если листов несколько - цикла-то по ним нет, а в архив Вы закидываете файл целиком. Поэтому опишите для начала чего хотите в итоге получить, а там уже может и решение нарисуется. В общих чертах, думаю, должно быть что-то вроде:
Код
Sub eng2()
    Dim ws As Worksheet
'разрыв связей
    Dim Connection As WorkbookConnection
    For Each Connection In ActiveWorkbook.Connections
        Connection.Delete
    Next
'архивация по заданному пути
defPath = "C:\"
    'Create date/time string and the temporary xls/zip file names
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameXls = defPath & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & strDate & ".xlsb"
    For Each ws In ActiveWorkbook.Worksheets
        FileNameZip = defPath & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & strDate & "_" & ws.Name & ".zip"
        If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
            'Make copy of the thisWorkbook
            ws.Copy
            ActiveWorkbook.SaveAs FileNameXls, ThisWorkbook.FileFormat 'Create empty Zip File
            ActiveWorkbook.Close 0
            DoEvents
            NewZip (FileNameZip)         'Copy the file in the compressed folder
            Set oApp = CreateObject("Shell.Application")
            oApp.Namespace(FileNameZip).CopyHere FileNameXls       'Keep script waiting until Compressing is done
            On Error Resume Next
            Do Until oApp.Namespace(FileNameZip).Items.Count = 1
                Application.Wait (Now + TimeValue("0:00:01"))
            Loop
            On Error GoTo 0
        End If
        Kill FileNameXls    ' удаляем временно созданный файл Excel
        DoEvents
    Next
    'MsgBox "Создан архив:  " & FileNameZip, vbInformation, "Готово"
    'Set fs = CreateObject("Scripting.FileSystemObject"):    'fs.MoveFile FileNameZip, "d:\"

End Sub
дальше уж сами по аналогии под свои задачи подправите.
Изменено: Дмитрий(The_Prist) Щербаков - 22.09.2019 15:16:44
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий, в основном файле несколько листов, я хочу, чтобы после обновления данных с помощью PQ, эти листы выносились в отдельные книги, рвались связи с PQ и выгружались на ресурс. Необязательно даже архивировать, нужно, чтобы конечные пользователи не могли вносить изменения в книгу - максимум - фильтрация.

Код не смогла опробовать - на NewZip, опять упирается в то,что Excel 2013?  
 
Цитата
Maayun написал:
опять упирается в то,что Excel 2013?
а мне откуда знать? Код, который я приложил работает, сам проверил. А что не работает у Вас - я не знаю, Вы даже не написали в чем проблема...Может надо диск С на свой заменить? А может надо правильно копировать. Сложно сказать, не имея никакой инф-ции об ошибке.
Изменено: Дмитрий(The_Prist) Щербаков - 22.09.2019 16:39:02
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий, выделяет NewZip - "Sub of Function not defined"
 
Цитата
Maayun написал:
выделяет NewZip - "Sub of Function not defined"
Вы хоть мат.часть подучите, что ли...Куда Вы вставили предложенный мной код и как? Я Вам привел измененную только одну процедуру - eng. А точнее - её копию. Все остальные надо было оставить там, где они были. Вы ведь из eng вызываете процедуру создания архива - NewZip. И если её не будет, то свою ошибку и получите.
Посмотрите на мой код, сверьте с кодами в своем файле и подумайте, что Вам надо было заменить :) Чисто логически хотя бы.
Изменено: Дмитрий(The_Prist) Щербаков - 22.09.2019 19:49:33
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 

Оставлю здесь свой макрос, он сохраняет выделенные листы в отдельные файлы и создаёт зип-архив с ними

Код
Sub CreateNewZip(sPath As String)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Sub расслитовка()
Dim s As Worksheet
Dim wb As Workbook
Dim pQuery As WorkbookQuery
Dim aw As Window
Set wb = ActiveWorkbook
Set aw = ActiveWindow
For Each s In aw.SelectedSheets
Set tempwindow = aw.NewWindow
Application.ScreenUpdating = False
s.Copy
For Each pQuery In ActiveWorkbook.Queries
        pQuery.Delete
Next
tempwindow.Close
Application.DisplayAlerts = False
Dim full_path As String
Dim folder_path As String
folder_path = wb.Path & "\" & "База региона " & s.Name & " " & Date & ".zip"
full_path = wb.Path & "\" & "База региона " & s.Name & " " & Date & ".xlsx"
ActiveWorkbook.SaveAs full_path


Call ZIPOneFile(folder_path, full_path)
ActiveWorkbook.Close


Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub


 
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
    Dim objShell As Object
    Dim lcnt As Long
 
    Set objShell = CreateObject("Shell.Application")
    'создаем пустой ZIP-архив, если его еще нет
    If Dir(sZIPFileName, 16) = "" Then
        CreateNewZip (sZIPFileName)
    End If
    lcnt = objShell.Namespace((sZIPFileName)).Items.Count
    'помещаем файлы из папки в архив
    objShell.Namespace((sZIPFileName)).CopyHere CStr(sFileToZIP)
    'дожидаемся окончания архивации
    Do Until objShell.Namespace((sZIPFileName)).Items.Count = lcnt + 1
        DoEvents
    Loop
End Function

Изменено: Maayun - 28.02.2020 23:10:48
Страницы: 1
Наверх