VBA - макрос excel

[Maza11]

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

Это возможно ???

[Maza11]

Цитата Maza11:



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

VBA - макрос excel

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

[Iska]

Iska,

круто, работает, НО

1. нельзя перетащить один файл, работает только если папку перетаскивать

2. не выставляет печать по ширине документа (фото распечатанного документа

https://www.dropbox.com/s/wxfgrma9oe...41.01.jpg?dl=0

)



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

[Maza11]

Цитата Maza11:



1. нельзя перетащить один файл, работает только если папку перетаскивать

VBA - макрос excel

Не было заказано. Было:


Цитата Maza11:



Можно ли как то его применить для всех документов в конкретной папке,

VBA - макрос excel

Если хотите и так, и этак, то вот:



Скрытый текст

[spoiler]Код:

[/spoiler]

Код: Выделить всё

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 & """ "
	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 и сослепу оставил после копирования куска кода вместо очистки объекта — его создание.




Цитата Maza11:



2. не выставляет печать по ширине документа (фото распечатанного документа

https://www.dropbox.com/s/wxfgrma9oe...41.01.jpg?dl=0

)

VBA - макрос excel

Я вроде как выставляю:



Код:

Код: Выделить всё

.PageSetup.FitToPagesWide = 1

Давайте попробуем добавить ещё и рекомендуемое «.Zoom = False».

[Iska]

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



Один файл перетягиваеш - работает, два или более - Usage: cscript.exe//nologo "Module.vbs"

папку перетягиваеш - работает.

Но то такое, главное такой титанический труд занимавший пол часа, теперь занимает одну минуту. понажимать ОК и все.





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



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



Код:

Код: Выделить всё

End With
				.PrintOut ,, 3

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



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



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

[Maza11]

Цитата Maza11:



два или более -

VBA - макрос excel

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




Цитата Maza11:



Usage: cscript.exe//nologo "Module.vbs"

VBA - макрос excel

Дабы не ошибаться при ручном наборе, используйте «Ctrl-C» для копирования содержимого диалогового окна типа MessageBox.




Цитата Maza11:



понажимать ОК и все.

VBA - макрос excel

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



Пробуйте:



Скрытый текст

[spoiler]Код:

[/spoiler]

Код: Выделить всё

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 & """  [ [...]]"
	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
'=============================================================================

Цитата Maza11:



p.s. и последняя "хотелка" … чтобы был еще один скрипт, который делал бы все тоже самое но непечатал.

VBA - макрос excel

Просто закомментируйте вывод на печать в этом отдельном скрипте:



Код:

Код: Выделить всё

						'.PrintOut ,, 3

[Iska]

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



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

http://rghost.ru/private/8PfsnjH6B/f...d5d81c3d8b9f35

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

[Maza11]

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



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

http://rghost.ru/private/8PfsnjH6B/f...d5d81c3d8b9f35

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

[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

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