用vbscripting操控excel:比较两张excel表的不同并复制出来放到新建表中
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'以电缆编号为索引,比较两张表的差异,并将两张表的差异
'罗列在一张新表中
'差异要求:1。A表有B表没有的元组,存放在ASheet中
' 2。B表有A表没有的元组,存放在BSheet中
' 3。当两张表的电缆编号相同时候,比较两个元组
' 并将不同的元组写到difbook中
'在表的V列标记:
' 1.记录为独立存在,在A和B表中标记:missing(淡黄色)
' 2.当记录存在,但在两个记录并不完全相同的标记:difference(浅紫色)
' 3.当两条记录完全相同的标记;OK
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

const APathOfExcel = "F: ew bookGWS348_主干电缆拉放册9-27导入用.xls"
const BPathOFExcel = "F: ew book主干电缆拉放册10-9不能.xls"

'ARows:A表表示需要搜索的地方是:B列的第三行开始到第14行结束
'BRows:同理
const BRows = "B1:B1000"
const ARows = "B5:B1000"
'LengthOfA 是A表最后的行数
'LengthOfB 是B表最后的行数
const LengthOFA = 1000
const LengthOfB = 1000
const AStartRow = 5
const BStartRow = 1

'Length 表示两个excel表的列数(不包含备注)
const StartCol = 2
const Length = 19

'注释在那一行
const N = 21


dim xcl
'xBook为A表,yBook为B表
dim xBook,yBook

'xSheet1为xBook的第一张Excel表
'ySheet1为yBook的第一张Excel表
dim xSheet1,ySheet1

'addbook为用于存放差异的Excel表
dim addbook
dim DifSheet,ASheet,BSheet
'j,k为变量,具有指针作用
dim j,k,l

dim yEachC,xEachC


set xcl = CreateObject("Excel.application")
xcl.Visible = true
set xBook = xcl.Workbooks.Open( APathOfExcel )
set xSheet1 = xBook.WorkSheets(1)
set yBook = xcl.Workbooks.Open( BPathOFExcel )
set ySheet1 = yBook.WorkSheets(1)

set yEachC = ySheet1.cells
set xEachC = xSheet1.cells

set addBook = xcl.Workbooks.add
set difSheet = addBook.WorkSheets(1)
set ASheet = addBook.WorkSheets(2)
set BSheet = addBook.WorkSheets(3)

j = 1
k = 1
l = 1
'调用搜索函数
call SearchSub()
call BMissing()

difSheet.name = "difference"
ASheet.name = "ASheet"
BSheet.name = "BSheet"

call FreeSub()
msgbox "It's over!!!!!"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'SearchSub函数:这是一个搜索函数
'主要功能是: 搜索A表中 b表不存在的元素
' 当电缆编号相同时,比较元组中的相,
' 把有差异的元组列出来
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub SearchSub()
dim i
dim YN
'IRow用于存储ySheet1的行号码
dim IRow

for i = AStartRow to LengthOfA
' for each yEachC in LengthOfB
for each yEachC in ySheet1.Range(BRows)
if xSheet1.cells(i,2).value <> " " then
if yEachC.value = xSheet1.cells(i,2).value then
YN = "Y"
IRow = yEachC.Row
Exit for
else
YN = "N"
End if
End if
Next
if YN = "N" then
xSheet1.rows(i).copy ASheet.rows(j)
j=j+1
'对不存在的row上色,并且标记
xSheet1.rows(i).Interior.colorIndex = "36"
xSheet1.cells(i,N).value = "missing"
else
Call Difference(i,IRow)
End if
Next
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Difference函数:当查找到相同电缆时,就使用diffrence函数
'对比两个元组中的每一个cell是否相同
'i为xSheet的行指针,IRow为ysheet的行指针
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Difference(i,IRow)
dim j
dim IsCopy
IsCopy = "N"
dim f,g

'if xSheet1.cells(i,2).value <> " " then
xSheet1.cells(i , N).value = "OK"
ySheet1.cells(IRow , N).value = "OK"
'end if
for j = StartCol to Length
if xSheet1.cells(i,j).value <> ySheet1.cells(Irow,j).value then
if Iscopy = "N" then
xSheet1.rows(i).copy difSheet.rows(k)
xSheet1.rows(i).Interior.colorIndex = "39"
difSheet.Cells(k,j).Interior.colorIndex = "37"
f = k
k = k + 1
ySheet1.rows(Irow).copy difSheet.rows(k)
ySheet1.rows(Irow).Interior.colorIndex = "39"
difSheet.Cells(k,j).Interior.colorIndex = "37"
g = k
k = k + 2
xSheet1.cells(i,N).value = "difference"
ySheet1.cells(IRow,N).value = "difference"
IsCopy = "Y"
else
difSheet.Cells(f,j).Interior.colorIndex = "37"
difSheet.Cells(g,j).Interior.colorIndex = "37"
end if
End if
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'这是一个补充搜索:BMissing 表示 B存在而A没有的元组
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub BMissing()
dim i
dim YN
for i= BStartRow to LengthOfB
for each xEachC in xSheet1.Range(ARows)
if xEachC.value = ySHeet1.cells(i,2).value then
YN = "Y"
Exit for
else
YN = "N"
End if
Next
if YN = "N" then
ySheet1.rows(i).copy BSheet.rows(l)
l = l + 1
ySheet1.rows(i).Interior.colorIndex = "36"
ySheet1.cells(i,N).value = "missing"
End if
Next
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'释放全局变量
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FreeSub()
set xEachC = nothing
set yEachC = nothing
Set BSheet = nothing
Set ASheet = nothing
set DifSheet = nothing
set addBook = nothing
set ySheet1 = nothing
set xSheet1 = nothing
set xBook = nothing
set yBook = nothing
set xcl = nothing
End Sub




































































































































































































