Option Explicit
' header
WScript.Echo "*******************************************"
WScript.Echo "* Automatic sheets merger *"
WScript.Echo "* *"
WScript.Echo "* Copyrighted: Jochen Hebrecht *"
WScript.Echo "*******************************************"
' configuration
Dim pagesize
pagesize = 700
' init: original XLS
Dim excel_orig, book_orig, sheet_orig
Set excel_orig=CreateObject("Excel.Application")
' init: new XLS
Dim book_new, excel_new, sheet_new
Set excel_new=CreateObject("Excel.Application")
set book_new=excel_new.Workbooks.add
set sheet_new=book_new.WorkSheets(1)
' get current dir
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
' start script
if ( WScript.Arguments.Count <> 2 ) Then
WScript.StdOut.writeline " Use: cscript automaticsheetmerger.vbs
Else
Dim fso, msg
Set fso = CreateObject("Scripting.FileSystemObject")
Dim filespec
' delete old output if needed
filespec = WshShell.CurrentDirectory & "\" & WScript.Arguments(1)
If (fso.FileExists(filespec)) Then
fso.DeleteFile(filespec)
End if
' create new file
filespec = WshShell.CurrentDirectory & "\" & WScript.Arguments(0)
If (fso.FileExists(filespec)) Then
Set book_orig=excel_orig.Workbooks.Open(filespec)
Dim start, einde, left, first_hit
start = 1
einde = 1
left = 0
first_hit = 0
' loop sheets
For each sheet_orig in book_orig.Worksheets
Wscript.Echo "Reading: " & sheet_orig.Name
' copy data
sheet_orig.Activate
sheet_orig.UsedRange.Select
excel_orig.Selection.Copy
' measure size
Dim x_s, y_s
y_s = sheet_orig.UsedRange.Rows.Count
x_s = sheet_orig.UsedRange.Columns.Count
Dim current_size
current_size = 0
For each r in sheet_orig.UsedRange.Rows
current_size = current_size + r.RowHeight
Next
WScript.Echo "current_size: " & current_size
' paste
sheet_new.Activate
' if no more space, put pagebreak
if first_hit = 1 And current_size > left Then
sheet_new.HPageBreaks.Add(sheet_new.Rows(start))
end if
WScript.Echo "start:" & start
Wscript.Echo "Range: A" & start & ":" & ConvertColumnNumberToLetter(x_s) & (start + y_s - 1 )
sheet_new.Range("A" & start & ":" & ConvertColumnNumberToLetter(x_s) & (start + y_s - 1)).Select
sheet_new.Paste
' calculate new space left
Dim r, i, sum
i = 1
sum = 0
For each r in sheet_orig.UsedRange.Rows
sheet_new.UsedRange.Rows(i + start - 1).Rowheight = sheet_orig.UsedRange.Rows(i).RowHeight
sum = sum + sheet_orig.UsedRange.Rows(i).RowHeight
i = i + 1
Next
if current_size > left Then
left = sum mod pagesize
left = pagesize - left
else
left = left - sum
end if
WScript.Echo "left: " & left
' new start place
start = start + y_s + 1
WScript.Echo
first_hit = 1
Next
' save & close
book_new.saveas(WshShell.CurrentDirectory & "/" & WScript.Arguments(1))
book_new.close
excel_new.quit
book_orig.close
excel_orig.quit
Else
WScript.Echo " File: " & WScript.Arguments(0) & " does not exist!"
End If
End if
' converts the number of a column to the letter of the number
Function ConvertColumnNumberToLetter(ColumnNumber)
Dim IntegerResult, FractionalResult, Remainder, FirstLetter, SecondLetter
IntegerResult = ColumnNumber \ 26
FractionalResult = (ColumnNumber / 26) - IntegerResult
Remainder = ColumnNumber Mod 26
If IntegerResult = 0 Then
FirstLetter = ""
ElseIf IntegerResult = 1 And FractionalResult = 0 Then
FirstLetter = ""
ConvertColumnNumberToLetter = "Z"
Exit Function
ElseIf IntegerResult > 1 And FractionalResult = 0 Then
FirstLetter = Chr(64 + (IntegerResult - 1))
ConvertColumnNumberToLetter = FirstLetter & "Z"
Exit Function
Else
FirstLetter = Chr(64 + IntegerResult)
End If
SecondLetter = Chr(64 + Remainder)
ConvertColumnNumberToLetter = FirstLetter & SecondLetter
End Function
Add new comment