I just found an old VBScript I wrote once for a friend who needed to merge different sheets from Excel into 1 big sheet. I can't remember all functional specifications, but the original XLS file was coming from a software package which was used to calculate sizes, measurements, ... in certain constructions of buildings. This software package was generating an XLS file with 50 sheets. But for statistical reasons, it would have been better to put it in 1 sheet. I just tested the script, and it's still working :-)
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
