[ms office - 2010] Excel 2010 Automated Tidy

[Theldron]

Hello all,

 

I am trying to automate some of the tedious tasks for the admin staff. I am currently working with one member of staff who deals with assessment. When she exports marksheets from SIMS to excel for staff to fill in she has to do some tidying up on them, adjusting column width, deleting parts of it etc. She has to do this with 100+ marksheets, so I was wondering if I could set up a VBA program or macro to effect multiple sheets in a folder, in one go.

 

Is this possible? Any advice would be appreciated.

 

Sean

[LosOjos]

I have a VBScript which will take a folder full of exported marksheets ('unformatted', XML), resize the columns to auto-width, fit them on one page for printing and save as xlsx.

 

It could of course be adapted to do whatever you like to the sheets, but will give a good basis to develop on

 

'==========================================================================
'
' NAME: ExcelXMLtoXLS_Fit.vbs
'
' AUTHOR: [email protected]
' DATE  : 04/02/2011
'
' COMMENT: Batch converts Excel XML files to XLS and fits them to one page for printing.
' HOW TO USE: Drag a folder containing the XML files onto the script.
'==========================================================================
Option Explicit

Dim Arg 			'Script argument
Dim FSO			'File System Object
Dim oFol			'Folder object
Dim oFil			'File object
Dim oFils		'Files
Dim myExcel		'Excel object
Dim myWorkbook		'Workbook object
Dim mySheet			'new worksheet
Dim filePath	'Path to file (need for Excel to open the file)
Dim sGroupName
Dim oCell


'Check arguments
If WScript.Arguments.Length < 1 Then
MsgBox "Drag a folder containing Excel XML files onto this script", vbOKOnly, "Error!"
WScript.Quit
End If 

Set FSO = CreateObject("Scripting.FileSystemObject")
Arg = WScript.Arguments(0)
If FSO.FolderExists(Arg) = False Then
  MsgBox "Drag and drop a folder onto this script to print the contents."
  Set FSO = Nothing
  WScript.Quit
End If

Set myExcel = CreateObject("Excel.Application")
myExcel.Visible = True
myExcel.DisplayAlerts = False

'Get folder informaton
Set oFol = FSO.GetFolder(Arg)

Set oFils = oFol.Files
  For Each oFil in oFils  '-- enumerate files in the folder using For/Each. Each oFil is a File object.
filePath = oFil
Set myWorkbook = myExcel.Workbooks.Open(filePath)

Set mySheet = myWorkbook.Sheets.Add()

myWorkbook.Sheets("Sheet1").UsedRange.Copy
mySheet.Range("A1").PasteSpecial
mySheet.Cells.Font.Size = 14
mySheet.Cells.EntireColumn.AutoFit
mySheet.Columns("A").ColumnWidth = mySheet.Columns("A").ColumnWidth / 2
   	
'find the group name
sGroupName=""
For Each oCell in mySheet.Columns(1).Cells
	if left(oCell.text,len("Group Name")) = "Group Name" then
		sGroupName = right(oCell.Value, len(oCell.Value) - inStr(1, oCell.Value, ":", 1))
		exit for
	end if
Next

'Add title
mySheet.Range("A1").EntireRow.Insert
mySheet.Range("A1").EntireRow.Insert
mySheet.Range("A1").EntireRow.Font.Bold = True
mySheet.Range("A1").EntireRow.Font.Size = 18
mySheet.Range("A1").Value = left(FSO.GetFileName(oFil), InStr(1, FSO.GetFileName(oFil), "-", 1) - 1) & " -" & sGroupName

With mySheet.PageSetup
	.PrintArea = mySheet.UsedRange.Address
	.Orientation = 2
	.LeftMargin = myExcel.Application.InchesToPoints(0.25)
	.RightMargin = myExcel.Application.InchesToPoints(0.25)
	.TopMargin = myExcel.Application.InchesToPoints(0.75)
	.BottomMargin = myExcel.Application.InchesToPoints(0.75)
	.Zoom = False
	.FitToPagesWide = 1
	'.FitToPagesTall = 0
End With

myWorkbook.Sheets("Sheet1").Delete
myWorkbook.SaveAs oFol.Path & "\" & left(FSO.GetFileName(oFil), Len(FSO.GetFileName(oFil))-4) & ".xls", 56
myWorkbook.Close False
oFil.Delete
Set mySheet = Nothing
Set myWorkbook = Nothing
  Next 
myExcel.DisplayAlerts = True
myExcel.Application.Quit
Set myExcel = Nothing
Set oFils = Nothing
Set oFol = Nothing

 

One thing worth pointing out - for some reason I've never been able to work out, the sheets that come out of SIMS will not fit to one page properly in Excel. If you copy them to a new sheet in the same workbook however, they do. Odd, but it works, this script does that part automatically for you.

Edited October 24, 2014 by LosOjos

[Theldron]

Mate that is awesome just what I needed. Thanks so much.