Tuesday, July 19, 2011

Excel VBA

Lesson 4: Getting Tooled Up.
Recording Macros
Range( "A1:I1").Select
Translating Recorded Macros
Keyboard and Mouse to Script Translation
mySheet.Cells(1,1).Value = "Hello World "
mySheet.Range( "A1:A1 ").Value = "Hello World "
mySheet.Range( "A1:I1 ").Select
Range( "A1:I1 ").Select
With Selection.Interior
With mySheet.Range( "A1:I1 ").Interior
Translating Excel Constants
xlAutomatic = -4105
xlSolid = 1
With mySheet.Range( "A1:I1 ").Interor
.ColorIndex = 36
.Patern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Finding And Removing Bugs
For row = 1 To 10
myNumber = (row * row) / (row * 0.25)
Next
For row = 1 To 10
myNumber = (row * row) / (row * 0.25)
Wscript.Echo myNumber
Next
myList = " "
for row = 1 to 10
myNumber = (row * row) / (row * 0.25)
myList = myList & myNumber & ", "
next
Wscript.Echo myList
' Create Excel Etc
...
' Populate a Spreadsheet
for row=1 to 100
value=row * 10
mySheet.Cells(row,1).Value=valeu
next i
Option Explicit
Dim mySheet,row,value
' Create Excel Etc
...
' Populate a Spreadsheet
for row=1 to 100
value=row * 10
mySheet.Cells(row,1).Value=valeu
next i
Lesson 5: Starting To Work With Data
Special Folders
Option Explicit
Dim myShell, myPath
Set myShell = WScript.CreateObject("WScript.Shell")
myPath = myShell.SpecialFolders.Item("MyDocuments")
WScript.Echo "MyDocuments='" & myPath & "'"
Using 'SendTo' As A Really Easy Way To Run Scripts
Option Explicit
Dim myShell, sendToFolder, myScriptPath, myShortcut
Set myShell = WScript.CreateObject("WScript.Shell")
sendToFolder = myShell.SpecialFolders("SendTo")
myScriptPath = myShell.SpecialFolders("MyDocuments") & "\myMacro.lnk"
Set myShortcut = myShell.CreateShortcut(sendToFolder & "myMacro.lnk")
myShortcut.TargetPath = myScriptPath
myShortcut.Save
Saving And Opening From Special Folders
' This script saves a Workbook to the Desktop
Option Explicit
Dim myShell, myExcel, myWorkbook, mySheet, myShell, xlNormal
' Open Excel
Set myExcel = CreateObject("Excel.Application")
' Create a Workbook and set myWorkbook to refer to it
' all in one go
Set myWorkbook = myExcel.Workbooks.Add
Set mySheet = myWorkbook.Sheets(1)
mySheet.Cells(1,1).Value="Date"
mySheet.Cells(2,1).Value=Date()
mySheet.Cells(1,2).Value="Time"
With mySheet.Cells(2,2)
.Value=Now()
.NumberFormat = "[$-409]h:mm:ss AM/PM;@"
End With
mySheet.Columns(1).AutoFit
' Tell Excel not to complain about overwrite files and
' other things like that
myExcel.DisplayAlerts = FALSE
' Save Excel Workbook to Desktop
xlNormal = -4143
Set myShell=CreateObject("WScript.Shell")
myWorkbook.SaveAs myShell.SpecialFolders("Desktop") & "\AutoSaved.xls",xlNormal
myExcel.Quit
' This script opens the Workbook saved by the
' previous one
Dim myShell, myExcel,myShell
Set myExcel = CreateObject("Excel.Application")
Set myShell=CreateObject("WScript.Shell")
myExcel.Open myShell.SpecialFolders("Desktop") & "\AutoSaved.xls"
Merging Between Workbooks
Dictionary Objects
Dim myDictionary
Set myDictionary=CreateObject( "Scripting.Dictionary ")
myDictionary.Add "hack and slash ", "123 Fake Street "
Dim address
address = myDictionary.Item( "hack and slash ")
Wscript.Echo address
Simple Merge Script
Option Explicit
Dim myShell,myExcel,ordersWB
Dim customersWB,outputWB,myDict
Dim desktop,row,ordersSh,customersSh,outputSh
Set myExcel=CreateObject("Excel.Application")
Set myDict =CreateObject("Scripting.Dictionary")
Set myShell=CreateObject("WScript.Shell")
desktop=myShell.SpecialFolders("Desktop")
myExcel.Visible=TRUE
Set ordersWB=myExcel.Workbooks.Open(desktop & "\orders.xls")
Set customersWB=myExcel.Workbooks.Open(desktop & "\customers.xls")
Set outputWB=myExcel.Workbooks.Add()
Set ordersSh=ordersWB.Sheets(1)
Set customersSh=customersWB.Sheets(1)
Set outputSh=outputWB.Sheets(1)
' This loads the dictionary with the
' addresses keyed by name
row=2
While(NOT IsEmpty(customersSh.Cells(row,1)))
myDict.Add customersSh.Cells(row,1).Value,customersSh.Cells(row,3).Value
row=row+1
Wend
' Lay out the output sheet
outputSh.Cells(1,1).Value="Customer Name"
outputSh.Cells(1,2).Value="Part Number"
outputSh.Cells(1,3).Value="Quantity"
outputSh.Cells(1,4).Value="Date"
outputSh.Cells(1,5).Value="Address"
' This scans the orders and creates the output
row=2
While(NOT IsEmpty(ordersSh.Cells(row,1)))
outputSh.Cells(row,1).Value=ordersSh.Cells(row,1)
outputSh.Cells(row,2).Value=ordersSh.Cells(row,2)
outputSh.Cells(row,3).Value=ordersSh.Cells(row,3)
outputSh.Cells(row,4).Value=ordersSh.Cells(row,4)
' This is the merge, looking up the address from
' the Dictionary
outputSh.Cells(row,5).Value= _
myDict.Item(ordersSh.Cells(row,1).Value)
row=row+1
Wend
'Clean up output
outputSh.Columns("D:D").NumberFormat = _
"[$-F800]dddd, mmmm dd, yyyy"
outputSh.Columns("A:E").AutoFit
outputSh.Rows("1:1").Font.FontStyle = "Bold"
Dim MyString
myString = "VBSCript "
myString = LCase(Trim(myString'''))'''
' We can see here that the output is all lower case
' and the trailing space has gone.
Wscript.Echo "'" & myString "'"
Working Merge Script
Option Explicit
Dim myShell,myExcel,ordersWB,customersWB,outputWB,myDict
Dim desktop,row,ordersSh,customersSh,outputSh,key
Dim errorSh,errorRow,okRow
Set myExcel=CreateObject("Excel.Application")
Set myDict =CreateObject("Scripting.Dictionary")
Set myShell=CreateObject("WScript.Shell")
desktop=myShell.SpecialFolders("Desktop")
myExcel.Visible=TRUE
Set ordersWB=myExcel.Workbooks.Open(desktop & "\orders.xls")
Set customersWB=myExcel.Workbooks.Open(desktop & "\customers.xls")
Set outputWB=myExcel.Workbooks.Add()
Set ordersSh=ordersWB.Sheets(1)
Set customersSh=customersWB.Sheets(1)
Set outputSh=outputWB.Sheets(1)
Set errorSh=outputWB.Sheets(2)
' This loads the dictionary with the
' addresses keyed by name
row=2
While(NOT IsEmpty(customersSh.Cells(row,1)))
myDict.Add LCase(Trim(customersSh.Cells(row,1).Value)),customersSh.Cells(row,3).Value
row=row+1
Wend
' Lay out the output sheet
outputSh.Cells(1,1).Value="Customer Name"
outputSh.Cells(1,2).Value="Part Number"
outputSh.Cells(1,3).Value="Quantity"
outputSh.Cells(1,4).Value="Date"
outputSh.Cells(1,5).Value="Address"
errorSh.Cells(1,1).Value="Customer Name"
errorSh.Cells(1,2).Value="Part Number"
errorSh.Cells(1,3).Value="Quantity"
errorSh.Cells(1,4).Value="Date"
errorSh.Cells(1,5).Value="Address"
' This scans the orders and creates the output
' We need three different Row Variables because the
' Row we write to is not the same as the number
' as the one we read from any more
row=2
errorRow=2
okRow=2
While(NOT IsEmpty(ordersSh.Cells(row,1)))
key=Trim(LCase(ordersSh.Cells(row,1).Value))
' Here is the decision if the address can be looked up or not
If myDict.Exists(key) Then
' Yes it can - so put the Row into the ouput Sheet
outputSh.Cells(okRow,1).Value= _
ordersSh.Cells(row,1)
outputSh.Cells(okRow,2).Value= _
ordersSh.Cells(row,2)
outputSh.Cells(okRow,3).Value= _
ordersSh.Cells(row,3)
outputSh.Cells(okRow,4).Value= _
ordersSh.Cells(row,4)
outputSh.Cells(okRow,5).Value= _
myDict.Item(key)
okRow=okRow+1
Else
' No it cannot - so put the Row into
' the error Sheet
errorSh.Cells(errorRow,1).Value= _
ordersSh.Cells(row,1)
errorSh.Cells(errorRow,2).Value= _
ordersSh.Cells(row,2)
errorSh.Cells(errorRow,3).Value= _
ordersSh.Cells(row,3)
errorSh.Cells(errorRow,4).Value= _
ordersSh.Cells(row,4)
errorRow=errorRow+1
End If
row=row+1
Wend
'Clean up output
outputSh.Columns("D:D").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
outputSh.Columns("A:E").AutoFit
outputSh.Rows("1:1").Font.FontStyle = "Bold"
outputSh.Name="Orders To Process"
errorSh.Columns("D:D").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
errorSh.Columns("A:D").AutoFit
errorSh.Rows("1:1").Font.FontStyle = "Bold"
errorSh.Name="Errors"
Lesson 6: Reading & Writing Files
Writing To A Text File
Option Explicit
Dim myFSO, myTSO,myShell,myName,forWriting
forWriting=2
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set myShell=CreateObject("WScript.Shell")
' The file location (folder) and name are sent to the
' FSO as a single String: Folder Name \ File Name
myName=myShell.SpecialFolders("Desktop") & "\example.txt "
' The arguments to the OpenTextFile method here
' give the location\name, that we want to write
' and that it is OK to create the file if it does
' not already exist
Set myTSO = myFSO.OpenTextFile(myName,forWriting,true)
myTSO.WriteLine("Hello this is a text file")
myTSO.WriteLine("It was created by a script")
' It is good practice to always close a TextStream
myTSO.Close

Option Explicit
Dim myFSO, myTSO, myShell, myName, forWriting, forAppending
forWriting = 2
forAppending = 8
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set myShell=CreateObject("WScript.Shell")
' The file location (folder) and name are sent to the
' FSO as a single String: Folder Name \ File Name
myName=myShell.SpecialFolders("Desktop") & "\script.log"
' The arguments to the OpenTextFile method here
' give the location\name, that we want to write
' and that it is OK to create the file if it does
' not already exist
Set myTSO = myFSO.OpenTextFile(myName,forAppending,true)
myTSO.WriteLine("Script Run: " & now)
myTSO.Close
Reading From A Text File
Option Explicit
Dim myFSO,myExcel,myWorkbook,mySheet,myTS,row,line,keyWord,datum
' Another way of defining Variables which we will not
' change is to use the "Const " keyword
Const forReading = 1
Set myExcel=CreateObject("Excel.Application")
Set myWorkbook=myExcel.Workbooks.Add()
Set mySheet=myWorkbook.Sheets(1)
myExcel.Visible=TRUE
With mySheet
.Cells(1,1).Value="User"
.Cells(1,2).Value="Date"
.Cells(1,3).Value="Action"
End With
' Set row to the first Row we
' want to write to in Excel
row=2
' Open our file in a TextStream Object
Set myFSO=CreateObject("Scripting.FileSystemObject")
' This is how we open a file reading using the
' FileSystemObject
Set myTS=myFSO.OpenTextFile _
( _
"myFile.txt", _
forReading, _
FALSE _
)
' This means keep looping until the end of the file
While NOT myTS.AtEndOfStream
' Read a line of text and put it in
' the Variable line
line=myTS.ReadLine()
' Split the line in two iff it has a = in it
line=Split(line,"=")
'See if there are two parts or one
if UBound(line)=1 Then
datum=Trim(line(1))
end if
' It will always have at least one part once split
' Strip spaces off the beginning and end
' at the same time
keyWord=Trim(line(0))
'Make sure the key word is all lower case
keyWord=LCase(keyWord)
' Choose what to do depending on the line
if keyWord="end" Then
' At the end of a block, move down
' one row in Excel
row=row+1
elseif keyWord="user" Then
mySheet.Cells(row,1).Value=datum
elseif keyWord="date" Then
mySheet.Cells(row,2).Value=datum
elseif keyWord="action" Then
mySheet.Cells(row,3).Value=datum
end if
Wend
' For neatness - close the TextStream
myTS.Close
' Tidy up our spreadsheet
mySheet.Columns(1).Autofit
mySheet.Columns(2).Autofit
mySheet.Columns(2).Autofit
Reading And Writing In Chunks
Set myFSO=CreateObject("Scripting.FileSystemObject")
Set myTS=myFSO.OpenTextFile _
( _
"myFile.txt", _
forReading, _
FALSE _
)
' Read the entire contents at once
fileContents=myTS.ReadAll()
myTS.Close
Set myFSO=CreateObject("Scripting.FileSystemObject")
Set myTS=myFSO.OpenTextFile _
( _
"myFile.txt", _
forReading, _
FALSE _
)
' Read the entire contents at once
fileContents=myTS.ReadAll()
myTS.Close
' Do the replace of / with //
fileContents=Replace(fileContents,"/","//")
' Now write out our new file contents
Set myTS=myFSO.OpenTextFile _
( _
"myFile.txt", _
forWriting, _
TRUE _
)
' Write the entire contents at once
myTS.Write(fileContents)
myTS.Close
Listing Files
Option Explicit
Dim fso,myFolder,myFile,myShell,myList
Set myShell=CreateObject("WScript.Shell")
Set fso=CreateObject("Scripting.FileSystemObject")
Set myFolder = fso.GetFolder(myShell.SpecialFolders.Item("Desktop"))
myList=""
For Each myFile In myFolder.Files
With myFile
If _
LCase(Right(.name,4))=".xls" OR _
LCase(Right(.name,5))=".xlsx" _
Then _
myList=myList & .name & vbcrlf
End IF
End With
Next
WScript.Echo "Excel Files On The Desktop:" & vbcrlf & myList
With myFile
If _
LCase(Right(.name,4))=".xls" OR _
LCase(Right(.name,5))=".xlsx" _
Then _
myList=myList & .name & vbcrlf
End IF
End With
If _
LCase(Right(.name,4))=".xls" OR _
LCase(Right(.name,5))=".xlsx" _
Then _
myList=myList & .name & vbcrlf
End IF
Lesson 7: Enhanced Data Processing
Subroutines And Functions
Sub MakeYellow(myRange)
With myRange.Interior
.ColorIndex = 6
.Pattern = 1
.PatternColorIndex = -4105
End With
End Sub
Function AddTwoNumbers(a,b)
AddTwoNumbers=a+b
End Function
Option Explicit
WScript.Echo AddTwoNumbers(2,2)
WScript.Echo AddTwoNumbers(3,4)
Function AddTwoNumbers(a,b)
AddTwoNumbers=a+b
End Function
Option Explicit
Dim myExcel, myWorkbook,mySheet,col,row
Set myExcel=CreateObject("Excel.Application")
Set myWorkbook=myExcel.Workbooks.Add()
Set mySheet=myWorkbook.Sheets(1)
myExcel.Visible=true
' Create some data to demonstrate the Function
For row=1 to 10
mySheet.Cells(row,1)="Hello"
Next
mySheet.Cells(11,2)="This is not blank"
mySheet.Cells(12,1)="So this should be ucase"
mySheet.Columns(1).Autofit
mySheet.Columns(2).Autofit
' These three lines do all the work, they
' use pop-ups to tell us what is happening and
' call the Function
WScript.Echo "Click OK to make column 1 ucase"
row=UCaseCol(mySheet,1)
WScript.Echo row & " Rows were converted"
' This is the actual Function its self.
Function UCaseCol(theSheet,theCol)
Dim uRow,uCol
' The max number of rows could be bigger
' in Excel 2007 but in all previous versions
' it is 65536, so we will use that
For uRow=1 to 65536
' The max number of columns could bigger
' in Excel 2007 but in all previous versions
' it is 256, so we will use that
For uCol=1 to 256
If Not IsEmpty(theSheet.Cells(uRow,uCol).Value) Then
' Exit For forces the loop to stop
' in this case, it will stop the
' "For uCol" loop
Exit For
End If
Next
' If uCol=257 here then all Cells were empty
If uCol=257 Then
' This Exit For will case the "For uRow"
' loop to stop
Exit For
End If
With theSheet.Cells(uRow,theCol)
.Value=UCase(.Value)
End With
Next
' At this point uRow is always the first blank row
' but we want to give back the number of
' changed rows
UCaseCol=uRow-1
End Function
' A Function to create a new Excel Object and
' return a new Workbook from it
Function MakeExcelWorkbook()
Dim myExcel
Set myExcel=CreateObject( "Excel.Application ")
Set MakeExcelWorkbook=myExcel.Workbooks.Add()
End Function
Death By Dates
Option Explicit
Dim myExcel,myWorkbook,mySheet,row
Set myExcel = CreateObject("Excel.Application")
Set myWorkbook = myExcel.Workbooks.Add()
Set mySheet = myWorkbook.Sheets(1)
' This loop creates strings in dd/mm/yyyy format
' puts them into Cells. To force Excel into not
' interpreting the string in any way, I make it
' into a formula and use the Cell.Formula property
' rather than the Cell.Value property we normally
' use.
For row=1 To 10
' This sets a formula like ="11/01/2001"
mySheet.Cells(row+1,1).Formula = "=""" & (10+row) & "/01/2001"""
' This will just put in the date string
' like 11/01/2001 and it also sets the Cell
' format to show dates in long format to help
' make it clear what Excel's interpretation is
With mySheet.Cells(row+1,2)
.Value = "" & (10+row) & "/01/2001"
.NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
End with
Next
' This code puts in the column titles and makes
' them bold
mySheet.Cells(1,1).Value="Input"
mySheet.Cells(1,2).Value="Excel Interpretation"
mySheet.Range("A1:B1").Font.Bold = True
' Now we can autofit the width of the columns
' and as a nice touch, zoom into the spreadsheet
mySheet.Columns(1).Autofit
mySheet.Columns(2).Autofit
myExcel.ActiveWindow.Zoom = 200
' Finally, we had better make Excel visible!
myExcel.Visible = TRUE
DateAdd(Interval, Number, Date)
Option Explicit
Dim myExcel,myWorkbook,mySheet,year,month,day,myDate,startDate,row
Set myExcel = CreateObject("Excel.Application")
Set myWorkbook = myExcel.Workbooks.Add()
Set mySheet = myWorkbook.Sheets(1)
' This date cannot be confused because the day
' and month are the same, and it is a nice
' simple date.
' We will use it as the starting date from which to
' make our calculations
startDate=CDate("01/01/2000")
For row=1 to 10
' Here we set up the day month and year
myMonth=1
myYear=2001
myDay=row+10
' Write the 'raw' date string into Excel
mySheet.Cells(row+1,1).Formula = "=""" & myDay & "/01/2001"""
' Compute a true Date value for the date
' We start of with the startDate
myDate=startDate
' Then add in the appropreate number of years
' It does not matter if year < 2000, because this ' will still work OK myDate=DateAdd("YYYY",myYear-2000,myDate) ' Now we add in the appropreate number of months myDate=DateAdd("M",myMonth-1,myDate) ' And finally the appropreate number of days myDate=DateAdd("D",myDay-1,myDate) ' At this point myDate holds a Date type value ' that represents the date we are interested in. ' Excel does not need to interpret this value, ' because it is already a date, so Excel cannot ' make a mistake. With mySheet.Cells(row+1,2) .Value = myDate .NumberFormat = "[$-F800]dddd, mmmm dd, yyyy" End With Next ' This is just the same layout stuff as before mySheet.Cells(1,1).Value="Input" mySheet.Cells(1,2).Value="Excel Interpretation" mySheet.Range("A1:B1").Font.Bold = True mySheet.Columns(1).Autofit mySheet.Columns(2).Autofit myExcel.ActiveWindow.Zoom = 200 myExcel.Visible = TRUE myDate=startDate myDate=DateAdd("YYYY",myYear-2000,myDate) myDate=DateAdd("M",myMonth-1,myDate) myDate=DateAdd("D",myDay-1,myDate) myDate=DateSerial(year,month,day) Option Explicit Dim myDate myDate=DateSerial(2007,2,32) WScript.Echo myDate myDate= "1/1/2007 " myDate=DateAdd("M",2-1,myDate) myDate=DateAdd("D",32-1,myDate) WScript.Echo myDate Importing Data From CSV Files ' Create a CSV file with a load of dates in it. ' This script is here ' only to produce the input file for the next ' script " it is not really part of the example Option Explicit Dim myFSO, myTS,row Const forWriting = 2 Set myFSO=CreateObject("Scripting.FileSystemObject") Set myTS=myFSO.OpenTextFile("Date-data.csv",forWriting,TRUE) myTS.WriteLine "SerialNumber,Date" For row=0 to 99 ' This is a numerical trick to produce realistic ' serial numbers from the row Variable and dates ' in US format which a UK Excel setting will get ' wrong. myTS.WriteLine (NOT ((row + row * 65536) xor &H8888)) & ",8/" & (1+row-(31*Int(row/31))) & "/2006" Next myTS.Close ' Change the CSV file innards to force Excel ' to treat them as plain text Option Explicit Dim myExcel,myWorkbook,mySheet,row,myValue,myFSO,myTS,file Contents,myShell,myDesktop,splitted Const forReading=1 Const forWriting=2 Set myShell=CreateObject("WScript.Shell") myDesktop=myShell.SpecialFolders("Desktop") Set myFSO=CreateObject("Scripting.FileSystemObject") Set myTS=myFSO.OpenTextFile(myDesktop & "/Date-data.csv",forReading,FALSE) fileContents=myTS.ReadAll() myTS.Close fileContents=Replace(fileContents,"/","//") Set myTS=myFSO.OpenTextFile(myDesktop & "/Date-data-fixed.csv",forWriting,TRUE) myTS.Write(fileContents) myTS.Close ' Read the newly updated CSV file into Excel and ' then recreate the dates in a way Excel cannot ' get confused (see previous lesson) Set myExcel=CreateObject("Excel.Application") myExcel.Visible=TRUE ' Load the csv usign the Open Method of the ' Workbooks Collection Set myWorkbook=myExcel.Workbooks.Open(myDesktop & "/Date-data-fixed.csv") Set mySheet=myWorkbook.Sheets(1) ' This loop goes down the Rows from the first data ' until the first Row in which the "serial number" ' is blank For row=2 to 65536 If IsEmpty(mySheet.Cells(row,1).Value) Then Exit For ' Here we use the ever handy Split built in Function ' to split the date String in Excel into ' three bits (0, 1 and 2) myValue=mySheet.Cells(row,2).Value splitted=Split(myValue,"//") ' DateSerial can now be used to create a real Date ' value to put back into Excel myValue=DateSerial _ ( _ splitted(2), _ splitted(0), _ splitted(1) _ ) mySheet.Cells(row,2).Value=myValue ' Finally, we correct the other Cell values myValue=mySheet.Cells(row,1).Value myValue=Replace(myValue,"//","/") mySheet.Cells(row,1).Value=myValue Next ' The script creates a csv file where the serial ' numbers are interpreted by Excel as scientific ' numbers Option Explicit Dim myFSO, myTS,row Const forWriting = 2 Set myFSO=CreateObject("Scripting.FileSystemObject") Set myTS=myFSO.OpenTextFile("Serial-data.csv",forWriting,TRUE) myTS.WriteLine "SerialNumber,Action" For row=1 to 100 ' Here we use the same numerical trick to produce ' realistic looking serial numbers but with an 'e' ' in them so Excel misinterprets them as scientific ' notation myTS.WriteLine (NOT ((row + row * 65536) xor &H8888)) & "e" & row & ",Incomming" Next myTS.Close ' Change the CSV file innards to force Excel ' to treat them as plain text Option Explicit Dim myExcel,myWorkbook,mySheet,row,myValue,myFSO,myTS,file Contents,myShell,myDesktop,fixed Const forReading=1 Const forWriting=2 Set myShell=CreateObject("WScript.Shell") myDesktop=myShell.SpecialFolders("Desktop") Set myFSO=CreateObject("Scripting.FileSystemObject") Set myTS=myFSO.OpenTextFile(myDesktop & "/Date-data.csv",forReading,FALSE) fileContents=myTS.ReadAll() myTS.Close fileContents=Replace(fileContents,"e","ee") Set myTS=myFSO.OpenTextFile(myDesktop & "/Date-data-fixed.csv",forWriting,TRUE) myTS.Write(fileContents) myTS.Close ' Read the newly updated CSV file into Excel and ' then recreate the dates in a way Excel cannot ' get confused (see previous lesson) Set myExcel=CreateObject("Excel.Application") myExcel.Visible=TRUE ' Load the csv usign the Open Method of the ' Workbooks Collection Set myWorkbook=myExcel.Workbooks.Open(myDesktop & "/Date-data-fixed.csv") Set mySheet=myWorkbook.Sheets(1) ' This loop goes down the Rows from the first data ' until the first Row in which the "serial number " ' is blank For row=2 to 65536 If IsEmpty(mySheet.Cells(row,1).Value) Then Exit For ' This time we convert ee into e and the use the ' "Formula" techniques to force Excel not to ' interpret the serial number myValue=mySheet.Cells(row,1).Value fixed=Replace(myValue,"ee","e") mySheet.Cells(row,1).Formula = "=""" & fixed & """" ' Finally, we correct the other Cell values myValue=mySheet.Cells(row,2).Value myValue=Replace(myValue,"ee","e") mySheet.Cells(row,2).Value=myValue Next Creating Reports myReportFile.WriteLine("

")
myReportFile.WriteLine("

")
for row = 1 to 10
myReportFile.WriteLine("

")
for column = 1 to 2
myReportFile.WriteLine("

")
next
myReportFile.WriteLine("")
next
myReportFile.WriteLine("
" & row & "," & column & "


")
Lesson 8: Working With Pivot Tables
Creating An Example Pivot Table
Option Explicit
' Script to make some data for pivot table work
Dim myExcel,myWorkbook,mySheet
Dim row,rTime,wOffice,wEquipment, office, equipment
Dim r1,r2
Set myExcel=CreateObject("Excel.Application")
Set myWorkbook=myExcel.WorkBooks.Add()
Set mySheet=myWorkbook.Sheets(1)
myExcel.Visible=TRUE
mySheet.Cells(1,1).Value="Office"
mySheet.Cells(1,2).Value="Equipment"
mySheet.Cells(1,3).Value="Repair Time"
mySheet.Cells(1,4).Value="Job Number"
For row=2 To 301
wOffice=Fix(rnd()*4+1)
if wOffice = 1 then
office="UK"
elseif wOffice < 4 then office="US" else office="Ch" end if mySheet.Cells(row,1).Value=office wEquipment=Fix(rnd()*6+1) if wEquipment=1 then equipment="Modem" elseif wEquipment=2 then equipment="Hard Drive" elseif wEquipment=3 then equipment="Monitor" elseif wEquipment=4 then equipment="Keyboard" else equipment="Power Supply" end if mySheet.Cells(row,2).Value=equipment rTime=Fix(rnd()*10+1)+Fix(rnd()*(10+wOffice)+1) mySheet.Cells(row,3).Value=rTime mySheet.Cells(row,4).Value=Fix(Rnd()*999+1000) &"-" &Fix(Rnd()*999+1000) Next mySheet.Columns(1).Autofit mySheet.Columns(2).Autofit mySheet.Columns(3).Autofit mySheet.Columns(4).Autofit Looking At The Recorded Macro ' Raw Recorded Macro ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ "Sheet1!R1C1:R301C4").CreatePivotTable "PivotTable1", DefaultVersion:=xlPivotTableVersion10 ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1) ActiveSheet.Cells(3, 1).Select ActiveWorkbook.ShowPivotTableFieldList = True With ActiveSheet.PivotTables("PivotTable1").PivotFields("Office") .Orientation = xlRowField .Position = 1 End With With ActiveSheet.PivotTables("PivotTable1").PivotFields("Equipment") .Orientation = xlColumnField .Position = 1 End With ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _ "PivotTable1").PivotFields("Repair Time"), "Sum of Repair Time", xlSum Range("B5").Select ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of Repair Time"). _ Function = xlAverage Range("B5:G8").Select Selection.NumberFormat = "0.00" ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True ActiveSheet.PivotTables("PivotTable1").Format xlTable2 OK " brace ourselves " we're going in: ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ "Sheet1!R1C1:R301C4").CreatePivotTable "PivotTable1", DefaultVersion:=xlPivotTableVersion10 ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1) ActiveSheet.Cells(3, 1).Select ActiveWorkbook.ShowPivotTableFieldList = True With ActiveSheet.PivotTables("PivotTable1").PivotFields("Office") .Orientation = xlRowField .Position = 1 End With With .Orientation = xlColumnField .Position = 1 End With ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _ "PivotTable1").PivotFields("Repair Time"), "Sum of Repair Time", xlSum Range("B5").Select ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of Repair Time"). _ Function = xlAverage Range("B5:G8").Select Selection.NumberFormat = "0.00" ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True ActiveSheet.PivotTables("PivotTable1").Format xlTable2 ' Fixing the number format without using a Range With ActiveSheet.PivotTables("PivotTable1").PivotFields( _ "Average of Repair Time") .NumberFormat = "0.00" End With ' Fixing number format translated With myTable.PivotFields("Average of Repair Time") .NumberFormat = "0.00" End With Finished Product Dim myWorkbook, myCache, myTable Const xlPivotTableVersion10 = 1 Const xlRowField = 1 Const xlColumnField = 2 Const xlAverage = -4106 Const xlTable2 = 11 Const xlDatabase = 1 ' This could be replaced with code which gets ' the Workbook Object myExcel.Workbooks.Add() ' or some other method. Set myWorkbook = ActiveWorkbook ' Here I split that massive statement in the recorded ' Macro into two steps; this is the first step to ' create the PivotCache. Also note that Excel has Set myCache = myWorkbook.PivotCaches.Add _ ( _ xlDatabase, _ "Sheet1!R1C1:R301C4" _ ' This is the second step which creates the ' PivotTable from the PivotCache Set myTable= myCache.CreatePivotTable _ ( _ "", _ "PivotTable1", _ TRUE, _ xlPivotTableVersion10 _ ) ' Now we have the table in existence, we can add ' the summary methods to it. With myTable.PivotFields("Office") .Orientation = xlRowField .Position = 1 End With With myTable.PivotFields("Equipment") .Orientation = xlColumnField .Position = 1 End With ' There is no point in a script of adding the ' Data field summarised as sum and then changing ' over to average. Here I have added it as average ' to start with. myTable.AddDataField myTable.PivotFields("Repair Time"), "Average of Repair Time", xlAverage ' Here is the nice clean number format approach myTable.PivotFields("Average of Repair Time") .NumberFormat = "0.00" End With ' Next we can set the auto-format we want myTable.Format xlTable2 ' Finally, we can clean up a bit by getting rid ' of the field list and the PivotTable command bar Application.CommandBars("PivotTable").Visible = False myWorkbook.ShowPivotTableFieldList = False Banding Data mySheet.Cells(1,5).Value = "Over Limit" mySheet.Cells(2,5).Formula = "=if(C2>14,1,0)"
mySheet.Range("E2:E301").FillDown
Option Explicit
' ... Some other code goes here ...
Dim myTable,myCache
Const xlDatabase = 1
Const xlRowField = 1
Const xlColumnField = 2
Const xlPivotTableVersion10 = 1
Const xlSum = -4157
Const xlCount = -4112
Const xlAverage = -4106
mySheet.Cells(1,5).Value = "Over Limit"
mySheet.Cells(2,5).Formula = "=if(C2>14,1,0)"
mySheet.Range("E2:E301").FillDown
Set myCache = myWorkbook.PivotCaches.Add _
( _
xlDatabase, _
"Sheet1!R1C1:R301C5" _
)
Set myTable=myCache.CreatePivotTable _
( _
"", _
"PivotTable1", _
true, _
xlPivotTableVersion10 _
)
With myTable.PivotFields("Office")
.Orientation = xlRowField
.Position = 1
End With
With myTable.PivotFields("Equipment")
.Orientation = xlColumnField
.Position = 1
End With
myTable.AddDataField _
myTable.PivotFields("Repare Time"), _
"Average of Repare Time",_
xlAverage
myTable.AddDataField _
myTable.PivotFields("Over Limit"), _
"Sum of Over Limit", _
xlSum
myTable.AddDataField _
myTable.PivotFields("Over Limit"), _
"Count Of Jobs", _
xlCount
Lesson 9: Working 'Outside The Box'
Accessing Binary Files
dim adodb
set adodb=WScript.CreateObject("ADODB.Connection")
dim v
WScript.echo "Your ADODB Version=" &adodb.version
' This is a simple example of managing binary files in
' vbscript using the ADODB object
dim inStream,outStream
const adTypeText=2
const adTypeBinary=1
' We can create the scream object directly, it does
' not need to be built from a record set or anything
' like that
set inStream=WScript.CreateObject("ADODB.Stream")
' We call open on the stream with no arguments.
' This makes the stream become an empty container
' which can be then used for what operations we want
inStream.Open
inStream.type=adTypeBinary
' Now we load a really BIG file. This should show
' if the object reads the whole file at once or just
' attaches to the file on disk
' You must change this path to something on your
' computer!
inStream.LoadFromFile "C:\temp\test.gif "
' Copy the data over to a stream for outputting
set outStream=WScript.CreateObject("ADODB.Stream")
outStream.Open
outStream.type=adTypeBinary
dim buff
buff=inStream.Read()
' Write out to a file
outStream.Write(buff)
' You must change this path to something on your
' computer!
outStream.SaveToFile "C:\temp\test.gif "
outStream.Close
inStream.Close
dim outStream
const adTypeText=2
const adTypeBinary=1
dim data
' Copy the dat over to a stream for outputting
set outStream=WScript.CreateObject("ADODB.Stream")
outStream.Open
outStream.type=adTypeBinary
dim buff()
redim buff(255)
dim i
for i=0 to 255
buff(i)=i
next
' Write out to a file - but the script fails here
outStream.Write(buff)
outStream.SaveToFile "C:\temp\test.gif "
outStream.Close
inStream.Close
Reading Data From Binary Files " An Example
Option Explicit
Dim myShell, sendToFolder, myPicturesPath, myShortcut
Dim fso,myFolder, myFile, fileName, comment, myExcel
Dim myWorkbook, myRow, mySheet
' Find "My Pictures"
Set myShell = CreateObject("WScript.Shell")
myPicturesPath = myShell.SpecialFolders("MyDocuments") &"\My Pictures"
' Open "My Pictures" as a folder so we can see
' which files are inside it
Set fso=CreateObject("Scripting.FileSystemObject")
Set myFolder=fso.GetFolder(myPicturesPath)
' Set Up Excel To receive The Data
Set myExcel=CreateObject("Excel.Application")
Set myWorkbook=myExcel.Workbooks.Add
Set mySheet=myWorkbook.Sheets(1)
myRow=2
mySheet.Cells(1,1).Value="Name"
mySheet.Cells(1,2).Value="GIF Type"
myExcel.Visible=TRUE
' Loop through each file found and see
' if its file extension is .gif
' If a file is a .gif file then call our function
' which opens it as a binary file and reads the
' version label
for each myFile in myFolder.Files
fileName=myFile.name
fileName=Lcase(fileName)
if Right(fileName,4)=".gif" then
' Read the version label
comment=GetGifComment(myFile.path)
' Place the data in the spreadsheet
mySheet.Cells(myRow,1).Value=fileName
mySheet.Cells(myRow,2).Value=comment
' Step down to the next Row
myRow=myRow+1
end if
next
' Make the spreadsheet look a bit nicer
With mySheet.Range("A1:B1").Font
.FontStyle = "Bold"
.Size = 12
End With
mySheet.Columns(1).Autofit
mySheet.Columns(2).Autofit
'Script ends here
function GetGifComment(gifFilePath)
dim inStream,buff,commentLen,commentStr,myIndex
dim myByte,myByteValue,myCharacter
set inStream=WScript.CreateObject("ADODB.Stream")
inStream.Open
inStream.type=1
inStream.LoadFromFile gifFilePath
buff=inStream.Read()
inStream.Close
commentStr=""
for myIndex = 1 to 6
' Extract 1 byte from the buffer
myByte = MidB(buff,myIndex,1)
' Gets its numeric value
myByteValue = AscB(myByte)
' Convert that numeric value into a character
myCharacter = Chr(myByteValue)
' Append that character to the string
commentStr = commentStr &myCharacter
next
GetGifComment = commentStr
end function
Sending Key Strokes To Other Applications Through
Option Explicit
Dim WshShell
' Open notepad
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "notepad", 9
' Give Notepad time to load (500 milliseconds)
WScript.Sleep 500
' Write FRED
WshShell.SendKeys "FRED"
Option Explicit
dim WshShell, myExcel, myWorkbook, mySheet
' Open Excel
set myExcel = CreateObject("Excel.Application")
' Create a Workbook and set myWorkbook to refer to it
' all in one go
set myWorkbook = myExcel.Workbooks.Add
set mySheet = myWorkbook.Sheets(1)
mySheet.Cells(1,1).Value="Hellow"
mySheet.Cells(1,2).Value="World"
mySheet.Cells(1,3).Value="This"
mySheet.Cells(2,1).Value="Is"
mySheet.Cells(2,2).Value="An"
mySheet.Cells(2,3).Value="Example"
mySheet.Cells.Copy
' Tell Excel not to ask if the document
' should be saved or to show any other alerts
myExcel.DisplayAlerts = FALSE
' Shut down Excel as we do not require it any more
myExcel.Quit
' Open notepad
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "notepad", 9
WScript.Sleep 500
' Do The Paste
WshShell.SendKeys "%e"
WshShell.SendKeys "p"
Stopping Excel From Complaining
myExcel.DisplayAlerts = FALSE
Lesson 10: Speeding Scripts Up
Cell By Cell Access Is Slow
set myExcel = CreateObject("Excel.Application")
myExcel.Visible = true
set myWorkbook = myExcel.Workbooks.Add
set mySheet = myWorkbook.Sheets(1)
' Get the start time
startTime = Timer()
' Load values into 1000 Cells directly
for row = 2 to 1001
mySheet.Cells(row,1).Value = "Hello " &row
next
' Get the end time
endTime = Timer
' Lay out the results column headings,
' Work out the result using an Excel formula
' and make the Columns automatically set themselves
' to an appropriate width
With mySheet
.Cells(1,1).Value = "Data"
.Cells(1,2).Value = "Start"
.Cells(1,3).Value = "End"
.Cells(1,4).Value = "Time"
.Cells(2,2).Value = startTime
.Cells(2,3).Value = endTime
.Cells(2,4).Formula = "=C2-B2"
.Columns(1).Autofit
.Columns(2).Autofit
.Columns(3).Autofit
.Columns(4).Autofit
End With
What Is An Array?
s1 = "hello 1 "
s2 = "hello 2 "
s3 = "hello 3 "
dim myString(2)
myString(0) = "hello 1 "
myString(1) = "hello 2 "
myString(2) = "hello 2 "
Using Arrays Like Spread Sheets
set myExcel = CreateObject("Excel.Application")
myExcel.Visible = true
set myWorkbook = myExcel.Workbooks.Add
set mySheet = myWorkbook.Sheets(1)
' Get the start time
startTime = Timer()
' Create a 1000 by 1 array and load data into it
dim data(999,0)
for row = 0 to 999
data(row,0) = "Hello " &row
next
' Bulk load a 1000 by 1 Cells Range of the spread
' sheet from the array
mySheet.Range _
( _
mySheet.Cells(2,1), _
mySheet.Cells(1002,1) _
).Value=data
' Get the end time
endTime=Timer
' Here I have omitted the result printing and
' formating because it is identical to the previous
' script.
Bulk Data Transfer With Copy/Paste
Option Explicit
Dim myExcel,myWorkbook,mySheet
Set myExcel=CreateObject("Excel.Application")
myExcel.Visible=TRUE
Set myWorkbook=myExcel.Workbooks.Add()
Set mySheet=myWorkbook.Sheets(1)
mySheet.Cells(1,1).Value="Hello"
mySheet.Select
mySheet.Cells.Copy
myWorkbook.Sheets(2).Select
myWorkbook.Sheets(2).Paste
Don't Forget Formulae And Fills
mySheet.Cells(1,5).Value = "Over Limit"
mySheet.Cells(2,5).Formula = "=if(C2>14,1,0)"
mySheet.Range("E2:E301").FillDown
Appendix A: Differences With Excel 2007
Creating A Pivot Table
' Raw Macro Recording For Creating A Pivot Table In Excel 2007
Sheets.Add
ActiveWorkbook.Worksheets("Sheet4").PivotTables("PivotTable1").PivotCache. _
CreatePivotTable TableDestination:="Sheet5!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion12
Sheets("Sheet5").Select
Cells(3, 1).Select
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Office")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Equipment")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Repair Time"), "Sum of Repair Time", xlSum
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of Repair Time")
.Caption = "Average of Repair Time"
.Function = xlAverage
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
"Average of Repair Time")
.NumberFormat = "0.00"
End With
ActiveSheet.PivotTables("PivotTable1").TableStyle2 = "PivotStyleLight19"























Posted by at

No comments:

Post a Comment

Subscribe to: Post Comments (Atom)