Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Программирование и базы данных (http://forum.oszone.net/forumdisplay.php?f=21)
-   -   макрос excel (http://forum.oszone.net/showthread.php?t=301901)

Maza11 01-07-2015 13:17 2524589
макрос excel
 
нужен простой макрос. в документ 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 01-07-2015 13:22 2524591
Maza11, упакуйте пару-тройку образцов документов в архив, прикрепите последний к сообщению или выложите на RGhost.

Maza11 01-07-2015 13:22 2524593
делал все через менюшки и выставлял уместить для печати на 1 страницу документ через предварительный просмотр - параметры страницы - разместить на 1 странице,
и при срабатывании макроса. он останавливается на окне предварительного просмотра

Maza11 01-07-2015 13:25 2524595
Вложений: 1
прикрепил образцы

Maza11 01-07-2015 13:34 2524603
нужно наверное еще два варианта в одном уместить по ширине на 1 страницу, в другом на 1 страницу и по ширине и высоте (чтобы фамилии и подписи не переносило на новый лист)

Iska 01-07-2015 13:49 2524614
Цитата:
Цитата Maza11
удалить два логотипа организации, »
Maza11, я вижу в выложенных документах только один рисунок на документ:
Скрытый текст

Поясните.

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

Maza11 01-07-2015 14:08 2524631
Цитата 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 01-07-2015 14:29 2524645
это еще не все оказалось, внизу строка есть

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

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

Iska 01-07-2015 16:42 2524709
Примерно так (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 01-07-2015 16:59 2524714
Цитата:
Iska превысил(а) максимальный объем сохраненных персональных сообщений и не может получать новые сообщения, пока не удалит часть старых
простите за глупый вопрос, но тот макрос что вы написали его нужно в редакторе макросов Microsoft Visual Basic открыть мой макрос PERSONAL.XLSB и вставить вместо него ?

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

Iska 01-07-2015 17:54 2524730
Цитата:
Цитата Maza11
сохранил ваш код в блокноте в файл Module3.bas нажимаю запустить его, тыкаю файл в wscript.exe, ругается »
Сохраните приведённый код в файл с расширением «.vbs». Перетащите целевую папку, содержащую файлы для обработки, на сохранённый скрипт.

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

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

Iska 02-07-2015 09:57 2524963
Цитата:
Цитата Maza11
1. нельзя перетащить один файл, работает только если папку перетаскивать »
Не было заказано. Было:
Цитата:
Цитата Maza11
Можно ли как то его применить для всех документов в конкретной папке, »
Если хотите и так, и этак, то вот:
Скрытый текст
Код:
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 и сослепу оставил после копирования куска кода вместо очистки объекта — его создание.

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

Maza11 02-07-2015 10:31 2524980
Идеально, печатает по ширине листа теперь.

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


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

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

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

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

Iska 03-07-2015 04:50 2525309
Цитата:
Цитата Maza11
два или более - »
Maza11, вот бы Вы заранее определились, а? Хотелки желательно озвучивать сразу.

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

Цитата:
Цитата Maza11
понажимать ОК и все. »
Если будете использовать «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
'=============================================================================

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

Maza11 03-07-2015 17:27 2525544
Очень благодарен Вам за помощь.

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

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

Maza11 04-07-2015 15:48 2525796
Или научите как самому написать

Maza11 07-07-2015 10:48 2526542
А если у меня есть код для макроса делающий разбивающий одну большую накладную на отдельные и размещает их с номерами 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 20-07-2015 17:32 2530597
нужно в документе менять дату
делаю так
Код:
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, какого там оператора не хватает ???

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

Iska 20-07-2015 17:48 2530603
Там лишнее.
Код:
.Replace "02.07.2015", "09.07.2015"

Maza11 20-07-2015 17:59 2530604
это я пытался на основе вашего скрипта модифицировать
сделал так
Код:
Sub WorkingWithWorkbook(objExcel, objFile)
        WScript.Echo objFile.Path
       
        With objExcel
                With .Workbooks.Open(objFile.Path)
                        With .Worksheets.Item(1).Range("A4:I4")
                                .Replace "02.07.2015", "09.07.2015"
                        End With
                       
                        .Save
                        .Close
                End With
        End With
End Sub
ругается, требуется объект objFile

Iska 20-07-2015 18:44 2530609
Цитата:
Цитата Maza11
ругается, требуется объект objFile »
Значит, Вы что-то не то передаёте в процедуру.

Maza11 20-07-2015 20:32 2530655
Цитата:
Цитата Iska
Значит, Вы что-то не то передаёте в процедуру. »
за основу взят Ваш скрипт
скрипт

Код:
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(objExcel, objFile)
        WScript.Echo objFile.Path
       
        With objExcel
                With .Workbooks.Open(objFile.Path)
                        With .Worksheets(1).Range("A4:I4")
                                .Replace "02.07.2015", "09.07.2015"                                               
                        End With
                       
                        .Save
                        .Close
                End With
        End With
End Sub
'=============================================================================

Iska 21-07-2015 00:20 2530730
Это не мой скрипт. Это непонятная компиляция.

Посмотрите сами:
Код:
…
WorkingWithWorkbook objFile, .GetExtensionName(objFile.Name)
…
Sub WorkingWithWorkbook(objExcel, objFile)
…

Maza11 21-07-2015 09:23 2530811
вот скрипт
скрипт оригинал
Код:
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

в нем я просто меняю эту часть
Код:
        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
на эту
Код:
        With .Workbooks.Open(objFile.Path)
            With .Worksheets(1).Range("A4:I4")
                .Replace "02.07.2015", "09.07.2015"                       
            End With
           
            .Save
            .Close
        End With
получается
скрипт измененный
Код:
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(1).Range("A4:I4")
                .Replace "02.07.2015", "15.07.2015"                       
            End With
           
            .Save
            .Close
        End With
    End With
End Sub

и для этих файлов он работает
http://rghost.ru/private/7pFNmtcC7/9...a20229c1c14670

но для двух других файлов, где это ячейка "A3:G3" не работает (просто меняю адрес ячейки)
http://rghost.ru/private/8V2CByf99/7...0a7ebd236852ec
выдает ошибка 800A03EC, адрес строка 71 символ 4 это символ табуляции перед Save
не понимаю почему так. для одних файлов работает. для других нет

Maza11 21-07-2015 09:57 2530825
похоже это ошибка уже не в скрипте т.к. те скрипты из которых брался код тоже стали эту ошибку выдавать на моменте сохранения, хотя они 100% рабочие, бред какой то уже

Maza11 21-07-2015 10:12 2530835
бред заключается в том, что с логотипами и процентами теми которые вы убирали изначально в скрипте, он не сохраняет измененную дату, если прогнать сначала скриптом убирающим их, а потом меняющим дату, то все ок

именно по этой причине в одних накладных работало, а в других нет.


Время: 02:27.

Время: 02:27.
© OSzone.net 2001-