'Core points of this execise:
'1. Excel writing function
'2. Excel add link to cell
'3. Creat new sheet
'4. Compare sheet content; add compare result to new sheet; add color to the result
'5. New a 'Function', 'sub'
Set ExcelObj = CreateObject("Excel.Application")
' add a new Workbooks and a new Sheet
ExcelObj.Workbooks.Add
Dim i,str
Dim filename
'2 sheets
For i=1 to 2
Set NewSheet = ExcelObj.Sheets.Item(i)
'define sheet name
NewSheet.Name = "Page Test " & i
' customize the Sheet layout
NewSheet.Cells(1,1).Value = "Website"
NewSheet.Cells(2,1).Value = "163.com"
'set different to the same cell in different sheet
If i=1 Then
NewSheet.Cells(3,1).Value = "hotmail.com"
Else
NewSheet.Cells(3,1).Value = "hotmail"
End If
'add link to cells
NewSheet.Hyperlinks.Add NewSheet.Cells(2,1), " http://www.163.com/ "
NewSheet.Hyperlinks.Add NewSheet.Cells(3,1), " http://www.hotmail.com/ "
Next
' call procesure to save file
filename="C:\test.xls"
Call Savefile (filename)
Dim rownum, colnum
rownum=3 'define row number
colnum=3 'define column number
'call function to compare 2 sheets
Set NewSheet = ExcelObj.Sheets.Item(3)
NewSheet.Name = "Compare Result"
'call function to find the compare result
str=CompareSheet(ExcelObj.Sheets.Item(1),ExcelObj.Sheets.Item(2), rownum, colnum )
If str=null then
NewSheet.Cells(1,1).Value ="They are the same."
else
NewSheet.Cells(1,1).Value ="They are different."
NewSheet.Cells(2,1).Value =str
End If
'save file
ExcelObj.ActiveWorkbook.Save
' close the application and clean the object
ExcelObj.Quit
Set ExcelObj = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'sub: save as file
Sub Savefile (filename)
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filename) Then
fso.DeleteFile(filename) 'if file exists, delete it
end if
ExcelObj.ActiveWorkbook.SaveAs filename
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'function: compare 2 sheets content
Function CompareSheet(sheet1, sheet2, row, col)
If sheet1 is nothing or sheet2 is nothing Then
CompareSheet=false
End If
Dim i, j
For i=1 to row
For j=1 to col
If sheet1.cells(i,j)<>sheet2.cells(i,j) Then
sheet1.cells(i,j).Font.Color=vbRed 'if 2 cells are different,, color of font will turn to red
str= "Cell(" & i & "," & j & "): '" & sheet1.cells(i,j) & "' and '" & sheet2.cells(i,j) & "'; " 'record the different content
Else
sheet1.cells(i,j).Font.Color=vbBlue 'if 2 cells are the same, color of font will turn to Blue
End If
Next
Next
CompareSheet=trim(str)
End Function