预测的近义词-胡底

'On Error Resume Next
Dim arrSheet1,arrSheet2,intCount1,intCount2
Dim eF1stCell,eFLastCell
Dim Texstr,sFileName
Dim db1(),db2()

Set moWindow=Object("ation", "IE_")
te2 "about:blank"
With Window
. "

"
. "

务必确保：比对文件的表头与标准文件的表头一致！（仅比对sheet1表）

"
. "

加载数据文件

"
. "

  "
. " "
. "  共计：行"
. "列

"
. "

  "
. " "
. "  共计：行"
. "列

"
. "

从第1列比对到第列，"
. "关键列是：（用“,”分割多列）"
. ""
. "    

"
. "信息提示：
"<br>. "

"

.MoveTo .idth/2-240,.eight/2-160
.ResizeTo 720,540
.="Excel文件数据比对工具"
End With

With moWindow
.FullScreen=0
.MenuBar=0
.AddressBar=0
.ToolBar=0
.StatusBar=0
.Resizable=0
.Visible=1
Set Form=.
Set .k=GetRef("Post_onClick")
Set .k=GetRef("Post1_onClick")
Set .k=GetRef("Post2_onClick")
End With
mbFinished=False
Do Until mbFinished
100
Loop


Sub IE_onQuit
mbFinished=True
End Sub


sub Post1_onClick
Dim str1
=BrowseForFile()
if ="" then
Texstr="请加载标准文件"
=Texstr
exit sub
end if
str1=pdxls_hl()
=str1(0)
=str1(1)
End sub


sub Post2_onClick
Dim str2
=BrowseForFile()
if ="" then
Texstr="请加载比对文件"
=Texstr
exit sub
end if
str2=pdxls_hl()
=str2(0)

ue=str2(1)
sFileName=Left(, InstrRev( , "")) & "" '定义比对报告文件
End sub


Sub Post_onClick
Dim gjlstr
if ="" or _
="" or _
="" then
Texstr="请完整输入上述相关数据!"
=Texstr
exit sub
end if
if Cint()>26 then
Texstr="比对列超过最大值！"
=Texstr
exit sub
end if
if Cint()>=Cint() then
if Cint()>Cint() then
Texstr="比对列超出范围！"
=Texstr
exit sub
end if
else
if Cint()>Cint() then
Texstr="比对列超出范围！"
=Texstr
exit sub
end if
end if
if <>"" then
gjlstr=Split(,",",-1,1)
for i=0 to UBound(gjlstr,1)
if Cint(gjlstr(i))>Cint() then
Texstr="关键列" & gjlstr(i) & "超出比对列！"
=Texstr
exit sub
end if
next
end if
Texstr="开始比对......"
if Cint()>=Cint() then
eFLastCell=Chr(Asc("A")+Cint()-1) &
else
eFLastCell=Chr(Asc("A")+Cint()-1) &
end if
eF1stCell="A1"
Texstr=Texstr+vbCrLf &"从" & eF1stCell & "比对到" & eFLastCell

arrSheet1=ReadExcel(,"Sheet1",eF1stCell,eFLastCell,False)
arrSheet2=ReadExcel(,"Sheet1",eF1stCell,eFLastCell,False)
sl=bs_ok()
Texstr=Texstr+vbCrLf & "有" & sl & "条数据一致（被标注OK）"
if <>"" then
for i=0 to UBound(gjlstr,1)
if isNumeric(gjlstr(i)) then
sl=bs_no(Cint(gjlstr(i))-1)
Texstr=Texstr+vbCrLf & "关键列" & gjlstr(i) & "比对有" & sl & "条数据被标注为NO"
end if
next
end if
saveFile()
Texstr=Texstr+vbCrLf & "比对完毕!详见报告文件：" & sFileName
=Texstr
End Sub


Function pdxls_hl(eFilename)
dim ExcelApp,ExcelBook,ExcelSheet
dim str0(2)
Set ExcelApp= CreateObject("ation")
Set ExcelBook= (eFilename)
Set ExcelSheet= ("Sheet1")

str0(0)=
str0(1)=


Set ExcelBook= Nothing
Set ExcelApp= Nothing
pdxls_hl=str0
end Function


'对数据一致的标注为"OK"
Function bs_Ok
Dim
i,sText
iok=0
ReDim Preserve db1(UBound(arrSheet1,2)+1)
ReDim Preserve db2(UBound(arrSheet2,2)+1)
For intCount1=0 To UBound(arrSheet1,2)
db1(intCount1)="NON-文件1"
next
For intCount2=0 To UBound(arrSheet2,2)
db2(intCount2)="NON-文件2"
next
For intCount1=1 To UBound(arrSheet1,2)
if StrComp(db1(intCount1),"NON-文件1")=0 then
For intCount2=1 To UBound(arrSheet2,2)
if StrComp(db2(intCount2),"NON-文件2")=0 then
sText=""
For i = 0 To Asc(eFLastCell)-Asc(eF1stCell)
if isDate(arrSheet1(i,intCount1)) then
if formatdatetime(arrSheet1(i,intCount1),2)<>formatdatetime(arrSheet2(i,intCount2),2) then
sText=sText&"-" & arrSheet1(i,0)
exit for
end if
Else
if isNumeric(arrSheet1(i,intCount1)) then
if formatnumber(arrSheet1(i,intCount1),2)<>formatnumber(arrSheet2(i,intCount2),2) then
sText=sText&"-" & arrSheet1(i,0)
exit for
end if
Else
if StrComp(Trim(Cstr(arrSheet1(i,intCount1))),Trim(Cstr(arrSheet2(i,intCount2))))<>0 then
sText=sText&"-" & arrSheet1(i,0)
exit fortttt
end if
end if
end if
Next
if Len(sText)=0 then
iok=iok+1
db1(intCount1)="OK-" & iok & "-文件1"
db2(intCount2)="OK-" & iok & "-文件2"
exit for
end if
end if
Next
end if
next
bs_Ok=iok
End Function


'对非OK的标注为"NO"
Function bs_No(gjl)
Dim i,sText
iok=0
For intCount1=1 To UBound(arrSheet1,2)
if StrComp(db1(intCount1),"NON-文件1")=0 then
For intCount2=1 To UBound(arrSheet2,2)
if StrComp(arrSheet1(gjl,intCount1),arrSheet2(gjl,intCount2))=0 then
if StrComp(db2(intCount2),"NON-文件2")=0 then
sText=""
For i = 0 To Asc(eFLastCell)-Asc(eF1stCell)
if isDate(arrSheet1(i,intCount1)) then
if formatdatetime(arrSheet1(i,intCount1),2)<>formatdatetime(arrSheet2(i,intCount2),2) then
sText=sText&"-" & arrSheet1(i,0)
end if
Else
if isNumeric(arrSheet1(i,intCount1)) then
if formatnumber(arrSheet1(i,intCount1),2)<>formatnumber(arrSheet2(i,intCount2),2) then
sText=sText&"-" & arrSheet1(i,0)
end if
Else
if StrComp(Trim(Cstr(arrSheet1(i,intCount1))),Trim(Cstr(arrSheet2(i,intCount2))))<>0 then
sText=sText&"-" & arrSheet1(i,0)tttt
end if
end if
end if
Next
if Len(sText)<>0 then
iok=iok+1
db1(intCount1)="NO-"&gjl+2&"-"&iok&"-文件1"
db2(intCount2)="NO-"&gjl+2&"-"&iok&"-文件2"&sText
exit for
end if
end if
end if
Next
end if
next
bs_No=iok
End Function


Sub saveFile
Dim oExcel
Dim oExcel1
Dim oExcel2
Dim hl1,i
Dim arrystr
Set oExcel = Object("ation")
e=true
yAlerts=FALSEtt'DisplayAlerts 属性禁止显示对话框和警告消息
e=FALSE ttt'调用EXCEL文件的时候
不显示
Set oExcel1 = (,true)
(1).Activate
Set oExcel2 = (,false)
(1).Activate

hl1="A" & UBound(arrSheet1,2)+2
(hl1).PasteSpecial

Set oExcel2=Nothing
(1).Columns(1).Insert
(1).Cells(1,1).Value="比对结果"
For intCount1=1 To UBound(arrSheet1,2)t
(1).Cells(intCount1+1,1).Value=db1(intCount1)
next
(1).Cells(intCount1+1,1).Value="比对结果"
For intCount2=1 To UBound(arrSheet2,2)t
(1).Cells(intCount1+1+intCount2,1).Value=db2(intCount2)
For i = 0 to Asc(eFLastCell)-Asc(eF1stCell)
if InStr(db2(intCount2),arrSheet1(i,0))<>0 then
(1).Cells(intCount1+1+intCount2,i+2).ndex=17
end if
Next
next
'(1).Columns("A:H").AutoFit() '设置A到H列自动调整列宽
(sFileName) '另存为sFileName

Set oExcel1 = Nothing

End sub


'用vbs读取Excel文件数据核心代码如下:
Function ReadExcel( myXlsFile, mySheet, my1stCell, myLastCell, blnHeader )
' Function : ReadExcel
' Version : 2.00
' This function reads data from an Excel sheet without using MS-Office
'
' Arguments:
' myXlsFile [string] The path and file name of the Excel file
' mySheet [string] The name of the worksheet used (e.g. "Sheet1")
' my1stCell [string] The index of the first cell to be read (e.g. "A1")
' myLastCell [string] The index of the last cell to be read (e.g. "D100")
' blnHeader [boolean] True if the first row in the sheet is a header
'
' Returns:
' The values read from the Excel sheet are returned in a two-dimensional
' array; the first dimension holds the columns, the second dimension holds
' the rows read from the Excel sheet.
'
' Written by Rob van der Woude
'
Dim arrData( ), i, j
Dim objExcel, objRS
Dim strHeader, strRange

Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

' Define header parameter string for Excel object
If blnHeader Then
strHeader = "HDR=YES;"
Else
strHeader = "HDR=NO;"
End If

' Open the object for the Excel file
Set objExcel = CreateObject( "tion" )
' IMEX=1 includes cell content of any format; tip by Thomas Willig
"Provider=.4.0;Data Source=" & _
myXlsFile & ";Extended Properties=""Excel 8.0;IMEX=1;" & _
strHeader & """"

' Open a recordset object for the sheet and range
Set objRS = CreateObject( "set" )
strRange = mySheet & "$$" & my1stCell & ":" & myLastCell
"Select * from [" & strRange & "]", objExcel, adOpenStatic

' Read the data from the Excel sheet
i = 0
Do Until
' Stop reading when an empty row is encountered in the Exc
el sheet
If IsNull( (0).Value ) Or Trim( (0).Value ) = "" Then Exit Do
' Add a new row to the output array
ReDim Preserve arrData( - 1, i )
' Copy the Excel sheet's row values to the array "row"
' IsNull test credits: Adriaan Westra
For j = 0 To - 1
If IsNull( (j).Value ) Then
arrData( j, i ) = ""
Else
arrData( j, i ) = Trim( (j).Value )
End If
Next
' Move to the next row
xt
' Increment the array "row" number
i = i + 1
Loop

' Close the file and release the objects


Set objRS = Nothing
Set objExcel = Nothing

' Return the results
ReadExcel = arrData
End Function


Function BrowseForFile()
Dim shell : Set shell = CreateObject("")
Dim fso : Set fso = CreateObject("stemObject")
Dim tempFolder : Set tempFolder = cialFolder(2)
Dim tempName : tempName = pName()
Dim tempFile : Set tempFile = TextFile(tempName & ".hta")
_
"" & _
"" & _
"" & _
"" & _
" " & _
"" & _
"