用vbscripting操控excel:比较两张excel表的不同并复制出来放到新建表中

本文介绍了一种使用VBA脚本比较两张Excel表格的方法,能够找出不同之处,并将差异内容复制到新的工作表中。此外,还实现了标记功能,以便于用户区分独立存在的记录、存在差异的记录以及完全相同的记录。

摘要生成于 C知道 ,由 DeepSeek-R1 满血版支持, 前往体验 >

用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)

= 1
= 1
= 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
评论 2
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值