макрос excel

[Maza11]

нужен простой макрос. в документ excel удалить два логотипа организации, уместить для печати на 1 страницу документ, сохранить и напечатать 3 копии.
Можно ли как то его применить для всех документов в конкретной папке, есть много папок по разным торг.точкам, но документ одинаковый и в каждой папке по 20-50 документов. чтобы каждый не открывать и не проделывать это все.

Пробовал записать макрос нажав на "Запись", вот такой код вышел

Sub лямина2()
'
' лямина2 Макрос
'
' Сочетание клавиш: Ctrl+l
'
Range("H4:I7").Select
Selection.ClearContents
ActiveSheet.Shapes.Range(Array("Picture -767")).Select
Selection.Delete
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.236220472440945)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWindow.SelectedSheets.PrintPreview
ActiveWorkbook.Save
ActiveWindow.SelectedSheets.PrintOut Copies:=3, Collate:=True, _
IgnorePrintAreas:=False
End Sub
применять для других документов его как не открывая каждый из 492 документов ???

[Iska]

Maza11, упакуйте пару-тройку образцов документов в архив, прикрепите последний к сообщению или выложите на RGhost.

[Maza11]

делал все через менюшки и выставлял уместить для печати на 1 страницу документ через предварительный просмотр - параметры страницы - разместить на 1 странице,
и при срабатывании макроса. он останавливается на окне предварительного просмотра

[Maza11]

прикрепил образцы

[Maza11]

нужно наверное еще два варианта в одном уместить по ширине на 1 страницу, в другом на 1 страницу и по ширине и высоте (чтобы фамилии и подписи не переносило на новый лист)

[Iska]

удалить два логотипа организации, »
Maza11, я вижу в выложенных документах только один рисунок на документ:
http://i.imgur.com/ReIQaeE.png
Поясните.

Далее:
уместить для печати на 1 страницу »
Надо полагать, Вы хотели сказать — по ширине на одну страницу?

[Maza11]

Цитата Iska:
, я вижу в выложенных документах только один рисунок на документ: »
под ним строка %!25 это тоже удалить

Цитата Iska:
Надо полагать, Вы хотели сказать — по ширине на одну страницу? »
да.

Просто внезапно озадачили. в спешке писал

делаю сейчас так

печатает, без лишних окон, но приходится открывать каждый документ, нажимать "Ctrl + L", закрывать и так далее
вот этот момент можно оптимизировать ?

Sub лямина2()
'
' лямина2 Макрос
'
' Сочетание клавиш: Ctrl+l
'
Range("H4:I7").Select
Selection.ClearContents
ActiveSheet.Shapes.Range(Array("Picture -767")).Select
Selection.Delete
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.236220472440945)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWorkbook.Save
ActiveWindow.SelectedSheets.PrintOut Copies:=3, Collate:=True, _
IgnorePrintAreas:=False
End Sub

[Maza11]

это еще не все оказалось, внизу строка есть

Автор друку: Хал....

но у нее разный адрес получается на каждом документе, поэтому удалять ее автоматически уже не знаю как

[Maza11]

думаю надо макросом удалять строку содержащую "Автор друку: ..." и строку перед ней, т.к. там какая то дурацкая строка идет высотой 300-400.
Это возможно ???

[Iska]

Примерно так (WSH, VBScript):
Option Explicit

Dim strSourceFolder

Dim objFile
Dim objExcel


If WScript.Arguments.Count = 1 Then
strSourceFolder = WScript.Arguments.Item(0)

With WScript.CreateObject("Scripting.FileSystemObject")
If .FolderExists(strSourceFolder) Then
Set objExcel = Nothing

For Each objFile In .GetFolder(strSourceFolder).Files
Select Case LCase(.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

WScript.Echo objFile.Path

With objExcel
With .Workbooks.Open(objFile.Path)
With .Worksheets.Item(1)
.Shapes.Item("Picture -767").Delete
.Range("H4:I6").Select
objExcel.Selection.ClearContents
.Range("A1").Select

objExcel.Union(.Rows(.UsedRange.Rows.Count).EntireRow, .Rows(.UsedRange.Rows.Count -1).EntireRow).Delete

.PageSetup.FitToPagesWide = 1
.PrintOut ,, 3
End With

.Save
.Close
End With
End With
Case Else
' Nothing to do
End Select
Next

If Not objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If
Else
WScript.Echo "Can't find source folder [" & strSourceFolder & "]."
WScript.Quit 2
End If
End with
Else
WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source folder>"
WScript.Quit 1
End If

WScript.Quit 0

Целевая папка указывается параметром скрипта (также можно просто перетащить папку на скрипт в Проводнике).

[Maza11]

Iska превысил(а) максимальный объем сохраненных персональных сообщений и не может получать новые сообщения, пока не удалит часть старыхпростите за глупый вопрос, но тот макрос что вы написали его нужно в редакторе макросов Microsoft Visual Basic открыть мой макрос PERSONAL.XLSB и вставить вместо него ?

сохранил ваш код в блокноте в файл Module3.bas нажимаю запустить его, тыкаю файл в wscript.exe, ругается

[Iska]

сохранил ваш код в блокноте в файл Module3.bas нажимаю запустить его, тыкаю файл в wscript.exe, ругается »
Сохраните приведённый код в файл с расширением «.vbs». Перетащите целевую папку, содержащую файлы для обработки, на сохранённый скрипт.

[Maza11]

Iska,
круто, работает, НО
1. нельзя перетащить один файл, работает только если папку перетаскивать
2. не выставляет печать по ширине документа (фото распечатанного документа https://www.dropbox.com/s/wxfgrma9oe8n31l/2015-07-02%2008.41.01.jpg?dl=0 )

p.s. в остальном все работает как надо. логотип и строку под ним удаляет, внизу строку "автор печати" удаляет, печатает 3 копии

[Iska]

1. нельзя перетащить один файл, работает только если папку перетаскивать »
Не было заказано. Было:
Можно ли как то его применить для всех документов в конкретной папке, »
Если хотите и так, и этак, то вот:
Option Explicit

Dim strSourceFileSystemObject

Dim objFile
Dim objExcel


If WScript.Arguments.Count = 1 Then
strSourceFileSystemObject = WScript.Arguments.Item(0)

With WScript.CreateObject("Scripting.FileSystemObject")
If .FolderExists(strSourceFileSystemObject) Then
Set objExcel = Nothing

For Each objFile In .GetFolder(strSourceFileSystemObject).Files
Select Case LCase(.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

WorkingWithWorkbook objExcel, objFile
Case Else
' Nothing to do
End Select
Next

If Not objExcel Is Nothing Then
objExcel.Quit
Set objExcel = Nothing
End If
ElseIf .FileExists(strSourceFileSystemObject) Then
Set objFile = .GetFile(strSourceFileSystemObject)

Select Case LCase(.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
With WScript.CreateObject("Excel.Application")
WorkingWithWorkbook .Application, objFile

.Quit
End With
Case Else
WScript.Echo "Source file [" & strSourceFileSystemObject & "] probably has not an Excel Workbook."
End Select

Set objFile = Nothing
Else
WScript.Echo "Can't find source file or source folder [" & strSourceFileSystemObject & "]."
WScript.Quit 2
End If
End with
Else
WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source file or source folder>"
WScript.Quit 1
End If

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub WorkingWithWorkbook(objExcel, objFile)
WScript.Echo objFile.Path

With objExcel
With .Workbooks.Open(objFile.Path)
With .Worksheets.Item(1)
.Shapes.Item("Picture -767").Delete
.Range("H4:I6").Select
objExcel.Selection.ClearContents
.Range("A1").Select

objExcel.Union(.Rows(.UsedRange.Rows.Count).EntireRow, .Rows(.UsedRange.Rows.Count -1).EntireRow).Delete

With .PageSetup
.Zoom = False
.FitToPagesWide = 1
End With

.PrintOut ,, 3
End With

.Save
.Close
End With
End With
End Sub
'=============================================================================


Я, кстати, в предыдущем коде забыл сделать выход из Excel и сослепу оставил после копирования куска кода вместо очистки объекта — его создание.

2. не выставляет печать по ширине документа (фото распечатанного документа https://www.dropbox.com/s/wxfgrma9oe...41.01.jpg?dl=0 ) »
Я вроде как выставляю:
.PageSetup.FitToPagesWide = 1
Давайте попробуем добавить ещё и рекомендуемое «.Zoom = False».

[Maza11]

Идеально, печатает по ширине листа теперь.

Один файл перетягиваеш - работает, два или более - Usage: cscript.exe//nologo "Module.vbs" <Soutce file or source folder>
папку перетягиваеш - работает.
Но то такое, главное такой титанический труд занимавший пол часа, теперь занимает одну минуту. понажимать ОК и все.


p.s. и последняя "хотелка"

попробовал убрать
End With

.PrintOut ,, 3
чтобы был еще один скрипт, который делал бы все тоже самое но непечатал. Ругается так на синтаксическую ошибку при выполнении

и еще тогда пусть будет отдельный скрипт который бы просто печатал по 3 копии документа XLS при перетягивании на него.

Чтобы уже на все случаи жизни.

[Iska]

два или более - »
Maza11, вот бы Вы заранее определились, а? Хотелки желательно озвучивать сразу.

Usage: cscript.exe//nologo "Module.vbs" <Soutce file or source folder> »
Дабы не ошибаться при ручном наборе, используйте «Ctrl-C» для копирования содержимого диалогового окна типа MessageBox.

понажимать ОК и все. »
Если будете использовать «cscript.exe» (будете использовать его напрямую, указывая в командной строке, або назначите его хостом по умолчанию для скриптов WSH) — нажимать «OK» не понадобится, сообщения будут выводиться в окно консоли. Либо можете просто закомментировать уведомление «WScript.Echo objFile.Path» в процедуре «WorkingWithWorkbook()».

Пробуйте:
Option Explicit

Dim objExcel

Dim strSourceFileSystemObject
Dim objFile


If WScript.Arguments.Count > 0 Then
With WScript.CreateObject("Scripting.FileSystemObject")
Set objExcel = Nothing

For Each strSourceFileSystemObject In WScript.Arguments
If .FolderExists(strSourceFileSystemObject) Then
For Each objFile In .GetFolder(strSourceFileSystemObject).Files
WorkingWithWorkbook objFile, .GetExtensionName(objFile.Name)
Next
ElseIf .FileExists(strSourceFileSystemObject) Then
WorkingWithWorkbook .GetFile(strSourceFileSystemObject), .GetExtensionName(strSourceFileSystemObject)
Else
WScript.Echo "Can't find source file or source folder [" & strSourceFileSystemObject & "]."
End If
Next

If Not objExcel Is Nothing Then
objExcel.Quit
Set objExcel = Nothing
End If
End With
Else
WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source file or source folder> [<Source file or source folder> [...]]"
WScript.Quit 1
End If

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub WorkingWithWorkbook(objFile, strExtension)
Select Case LCase(strExtension)
Case "xls", "xlsx"
WScript.Echo objFile.Path

If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

With objExcel
With .Workbooks.Open(objFile.Path)
With .Worksheets.Item(1)
.Shapes.Item("Picture -767").Delete
.Range("H4:I6").Select
.Parent.Parent.Selection.ClearContents
.Range("A1").Select

.Parent.Parent.Union(.Rows(.UsedRange.Rows.Count).EntireRow, .Rows(.UsedRange.Rows.Count -1).EntireRow).Delete

With .PageSetup
.Zoom = False
.FitToPagesWide = 1
End With

.PrintOut ,, 3
End With

.Save
.Close
End With
End With
Case Else
WScript.Echo "Source file [" & strSourceFileSystemObject & "] probably has not an Excel Workbook."
End Select
End Sub
'=============================================================================

p.s. и последняя "хотелка" … чтобы был еще один скрипт, который делал бы все тоже самое но непечатал. »
Просто закомментируйте вывод на печать в этом отдельном скрипте:
'.PrintOut ,, 3

[Maza11]

Очень благодарен Вам за помощь.

Но задача усложняется, эти чудики теперь стали присылать накладные в одном файле на 3000 строк, и нужно каждую накладную копировать оттуда и сохранять в новый файл :o
http://rghost.ru/private/8PfsnjH6B/fd93e39ec8f346763ed5d81c3d8b9f35

сможете помочь ???

[Maza11]

Или научите как самому написать

[Maza11]

А если у меня есть код для макроса делающий разбивающий одну большую накладную на отдельные и размещает их с номерами 01, 02, 03 .. в той же папке, помогите переделать ее на скрипт VBS т.к. у них отличается синтаксис чуть-чуть, всякие WScript добавляются, чтобы работало перетягивание файла из провдника, и накладные создавались в той же папке где файл оригинал лежит

Sub Эпицентр()
Dim fn As String, Sh As Worksheet, Sh_out As Worksheet
Dim Fout As String, Cl As Collection
fn = Get_FileName
If fn = "" Then Exit Sub

Application.ScreenUpdating = False
Fout = ThisWorkbook.Path
Set Cl = New Collection
Set Sh = Workbooks.Open(fn).Worksheets(1)
LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
dx = Sh.Range("A1:A" & LastRow)
ss = "1:"
For n = 1 To LastRow
If InStr(1, dx(n, 1), "Автор друку:", vbTextCompare) > 0 Then
ss = ss & (n - 1)
Cl.Add ss
ss = (n + 1) & ":"
End If
Next
For n = 1 To Cl.Count
ThisWorkbook.Worksheets("Документ").Copy
Set Sh_out = ActiveSheet
Sh.Rows(Cl.Item(n)).Copy Sh_out.Range("A1")
For Each hp In Sh_out.Shapes
hp.Delete
Next
Set xx = Sh_out.Cells.Find("%!", , , xlPart)
If Not xx Is Nothing Then xx.Value = ""

Sh_out.SaveAs Filename:=Fout & "\" & n & ".xls", FileFormat:=xlExcel8
Sh_out.Parent.Close (False)
Next

Sh.Parent.Close (False)
Application.ScreenUpdating = True

MsgBox "Game Over"
End Sub








Function Get_FileName(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal FilterDescription As String = "Файлы Excel", _
Optional ByVal FilterExtention As String = "*.xls*") As String
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen) '
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
Get_FileName = .SelectedItems(1)
End With



End Function

накладные должны быть отдельными файлами, без логотипа, без строки с процентами и автора друку и иметь вид по ширине листа, печатать их будет отдельно

[Maza11]

нужно в документе менять дату
делаю так
Sub WorkingWithWorkbook(objExcel, objFile)
WScript.Echo objFile.Path

With objExcel
With .Workbooks.Open(objFile.Path)
With .Worksheets(1).Range("A4:I4")
.Replace:="02.07.2015", Replacement:="09.07.2015"
End With

.Save
.Close
End With
End With
End Sub
ругается 800A0400 по адресу перед .Replace, какого там оператора не хватает ???

Подскажите пожалуйста