Код:
Option Explicit
Const intColumns = 7
Const intRows = 56
Dim strSourceFolder
Dim objFSO
Dim objFile
Dim objExcel
Dim objSourceSheet
Dim objDestSheet
Dim objSourceRange
Dim objDestRange
If WScript.Arguments.Count = 1 Then
strSourceFolder = WScript.Arguments.Item(0)
Set objExcel = Nothing
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strSourceFolder) Then
For Each objFile In objFSO.GetFolder(strSourceFolder).Files
Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If
With objExcel
With .Workbooks.Open(objFile.Path)
Set objSourceSheet = .Worksheets.Item(1)
Set objDestSheet = .Worksheets.Add
If StrComp(objSourceSheet.Cells(1, 1).Value, "num", vbTextCompare) = 0 Then
Set objSourceRange = objSourceSheet.Range(objSourceSheet.Cells(1, 1), objSourceSheet.Cells(intRows, 1))
Set objDestRange = objDestSheet.Cells(1, 1)
objSourceRange.Copy objDestRange
Do Until objExcel.Intersect(objSourceSheet.UsedRange, objSourceRange) Is Nothing
Set objSourceRange = objSourceRange.Offset(intRows, 0)
If objDestRange.Column = intColumns Then
objDestSheet.VPageBreaks.Add objDestRange.Offset(0, 1)
Set objDestRange = objDestRange.Offset(intRows, 1 - intColumns)
objDestSheet.HPageBreaks.Add objDestRange
Else
Set objDestRange = objDestRange.Offset(0, 1)
End If
objSourceRange.Copy objDestRange
Loop
objDestSheet.UsedRange.Columns.AutoFit
objDestSheet.PrintOut
Else
WScript.Echo "Can't find [num] in A1 cell in first worksheet in [" & objFile.Name & "] workbook."
End If
.Close False
End With
End With
Case Else
' Nothing to do
End Select
Next
objExcel.Quit
Set objExcel = Nothing
Else
WScript.Echo "Can't find source folder [" & strSourceFolder & "]."
WScript.Quit 2
End If
Else
WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source folder>"
WScript.Quit 1
End If
Set objFSO = Nothing
WScript.Quit 0
