[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/wxfgrma9oe...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 строк, и нужно каждую накладную копировать оттуда и сохранять в новый файл
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

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

[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, какого там оператора не хватает ???

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