'On Error Resume Next
Dim arrSheet1,arrSheet2,intCount1,intCount2
Dim eF1stCell,eFLastCell
Dim Texstr,sFileName
Dim db1(),db2()
Set moWindow=WScript.CreateObject("InternetExplorer.Application", "IE_")
moWindow.Navigate2 "about:blank"
With moWindow.Document.ParentWindow
.Document.Write "<font ></font><body bgcolor='#9999CC'><form>"
.Document.Write "<pre><b>务必确保：比对文件的表头与标准文件的表头一致！（仅比对sheet1表）</b></pre>"
.Document.Write "<fieldset><legend>加载数据文件</legend>"
.Document.Write "<pre> <input type='button' value='标准文件' name='Post1'/>"
.Document.Write " <input type='text' size='50' name='rfile1' readonly='readonly'/>"
.Document.Write " 共计：<input type='text' size='5' name='Row1' readonly='readonly'/>行"
.Document.Write "<input type='text' size='5' name='Col1' readonly='readonly'/>列</pre>"
.Document.Write "<pre> <input type='button' value='比对文件' name='Post2'/>"
.Document.Write " <input type='text' size='50' name='rfile2' readonly='readonly'/>"
.Document.Write " 共计：<input type='text' size='5' name='Row2' readonly='readonly'/>行"
.Document.Write "<input type='text' size='5' name='Col2' readonly='readonly'/>列</pre></fieldset>"
.Document.Write "<pre>从第1列比对到第<input type='text' maxlength='2' size='3' name='eFLastCell'/>列，"
.Document.Write "关键列是：<input type='text' maxlength='11' size='12' name='Gjl' Value='1'/>（用“,”分割多列）"
.Document.Write "<input type='reset' value=' 重置 ' />"
.Document.Write " <input type='button' value='开始比对！' name='Post'/></pre>"
.Document.Write "信息提示：</br><textarea rows=14 cols=52 name='MailText' readonly='readonly'/>"
.Document.Write "</textarea></br></form></body>"
.MoveTo .Screen.AvailWidth/2-240,.Screen.AvailHeight/2-160
.ResizeTo 720,540
.Document.Title="Excel文件数据比对工具"
End With
moWindow.Document.Close
With moWindow
.FullScreen=0
.MenuBar=0
.AddressBar=0
.ToolBar=0
.StatusBar=0
.Resizable=0
.Visible=1
Set Form=.Document.All
Set .Document.Click=GetRef("Post_onClick")
Set .Document.Click=GetRef("Post1_onClick")
Set .Document.Click=GetRef("Post2_onClick")
End With
mbFinished=False
Do Until mbFinished
WScript.Sleep 100
Loop
Sub IE_onQuit
mbFinished=True
End Sub
sub Post1_onClick
Dim str1
Form.rFile1.Value=BrowseForFile()
if Form.rFile1.Value="" then
Texstr="请加载标准文件"
Form.MailText.Value=Texstr
exit sub
end if
str1=pdxls_hl(Form.rFile1.Value)
Form.Row1.Value=str1(0)
Form.Col1.Value=str1(1)
End sub
sub Post2_onClick
Dim str2
Form.rFile2.Value=BrowseForFile()
if Form.rFile2.Value="" then
Texstr="请加载比对文件"
Form.MailText.Value=Texstr
exit sub
end if
str2=pdxls_hl(Form.rFile2.Value)
Form.Row2.Value=str2(0)
Form.Col2.Val
ue=str2(1)
sFileName=Left(Form.rFile2.Value, InstrRev( Form.rFile2.Value, "\")) & "compreport.xls" '定义比对报告文件
End sub
Sub Post_onClick
Dim gjlstr
if Form.eFLastCell.Value="" or _
Form.rFile1.Value="" or _
Form.rFile2.Value="" then
Texstr="请完整输入上述相关数据!"
Form.MailText.Value=Texstr
exit sub
end if
if Cint(Form.eFLastCell.Value)>26 then
Texstr="比对列超过最大值！"
Form.MailText.Value=Texstr
exit sub
end if
if Cint(Form.Col2.Value)>=Cint(Form.Col1.Value) then
if Cint(Form.eFLastCell.Value)>Cint(Form.Col1.Value) then
Texstr="比对列超出范围！"
Form.MailText.Value=Texstr
exit sub
end if
else
if Cint(Form.eFLastCell.Value)>Cint(Form.Col2.Value) then
Texstr="比对列超出范围！"
Form.MailText.Value=Texstr
exit sub
end if
end if
if Form.Gjl.Value<>"" then
gjlstr=Split(Form.Gjl.Value,",",-1,1)
for i=0 to UBound(gjlstr,1)
if Cint(gjlstr(i))>Cint(Form.eFLastCell.Value) then
Texstr="关键列" & gjlstr(i) & "超出比对列！"
Form.MailText.Value=Texstr
exit sub
end if
next
end if
Texstr="开始比对......"
if Cint(Form.Row2.Value)>=Cint(Form.Row1.Value) then
eFLastCell=Chr(Asc("A")+Cint(Form.eFLastCell.Value)-1) & Form.Row2.Value
else
eFLastCell=Chr(Asc("A")+Cint(Form.eFLastCell.Value)-1) & Form.Row1.Value
end if
eF1stCell="A1"
Texstr=Texstr+vbCrLf &"从" & eF1stCell & "比对到" & eFLastCell
arrSheet1=ReadExcel(Form.rFile1.Value,"Sheet1",eF1stCell,eFLastCell,False)
arrSheet2=ReadExcel(Form.rFile2.Value,"Sheet1",eF1stCell,eFLastCell,False)
sl=bs_ok()
Texstr=Texstr+vbCrLf & "有" & sl & "条数据一致（被标注OK）"
if Form.Gjl.Value<>"" 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
Form.MailText.Value=Texstr
End Sub
Function pdxls_hl(eFilename)
dim ExcelApp,ExcelBook,ExcelSheet
dim str0(2)
Set ExcelApp= CreateObject("Excel.Application")
Set ExcelBook= ExcelApp.Workbooks.Open(eFilename)
Set ExcelSheet= ExcelBook.Sheets("Sheet1")
str0(0)=ExcelApp.ActiveSheet.UsedRange.Rows.Count
str0(1)=ExcelApp.ActiveSheet.UsedRange.Columns.Count
ExcelBook.Close
ExcelApp.Quit
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 for
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)
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 = WScript.CreateObject("Excel.Application")
oExcel.visible=true
oExcel.DisplayAlerts=FALSE 'DisplayAlerts 属性禁止显示对话框和警告消息
oExcel.visible=FALSE '调用EXCEL文件的时候
不显示
Set oExcel1 = oExcel.Workbooks.Open(Form.rFile1.Value,true)
oExcel1.Sheets(1).Activate
Set oExcel2 = oExcel.Workbooks.Open(Form.rFile2.Value,false)
getsavefilenameoExcel2.Sheets(1).Activate
oExcel2.ActiveSheet.UsedRange.Copy
hl1="A" & UBound(arrSheet1,2)+2
oExcel1.ActiveSheet.Range(hl1).PasteSpecial
oExcel2.close
Set oExcel2=Nothing
oExcel1.Sheets(1).Columns(1).Insert
oExcel1.Sheets(1).Cells(1,1).Value="比对结果"
For intCount1=1 To UBound(arrSheet1,2)
oExcel1.Sheets(1).Cells(intCount1+1,1).Value=db1(intCount1)
next
oExcel1.Sheets(1).Cells(intCount1+1,1).Value="比对结果"
For intCount2=1 To UBound(arrSheet2,2)
oExcel1.Sheets(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
oExcel1.Sheets(1).Cells(intCount1+1+intCount2,i+2).lorindex=17
end if
Next
next
'oExcel1.Sheets(1).Columns("A:H").AutoFit() '设置A到H列自动调整列宽
oExcel1.SaveAs(sFileName) '另存为sFileName
oExcel1.close
Set oExcel1 = Nothing
oExcel.Quit
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
' bvanderwoude
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( "ADODB.Connection" )
' IMEX=1 includes cell content of any format; tip by Thomas Willig
objExcel.Open "Provider=Microsoft.Jet.OLEDB.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( "ADODB.Recordset" )
strRange = mySheet & "$" & my1stCell & ":" & myLastCell
objRS.Open "Select * from [" & strRange & "]", objExcel, adOpenStatic
' Read the data from the Excel sheet
i = 0
Do Until objRS.EOF
' Stop reading when an empty row is encountered in the Exc
el sheet
If IsNull( objRS.Fields(0).Value ) Or Trim( objRS.Fields(0).Value ) = "" Then Exit Do
' Add a new row to the output array
ReDim Preserve arrData( objRS.Fields.Count - 1, i )
' Copy the Excel sheet's row values to the array "row"
' IsNull test credits: Adriaan Westra
For j = 0 To objRS.Fields.Count - 1
If IsNull( objRS.Fields(j).Value ) Then
arrData( j, i ) = ""
Else
arrData( j, i ) = Trim( objRS.Fields(j).Value )
End If
Next
' Move to the next row
objRS.MoveNext
' Increment the array "row" number
i = i + 1
Loop
' Close the file and release the objects
objRS.Close
objExcel.Close
Set objRS = Nothing
Set objExcel = Nothing
' Return the results
ReadExcel = arrData
End Function
Function BrowseForFile()
Dim shell : Set shell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2)
Dim tempName : tempName = fso.GetTempName()
Dim tempFile : Set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
tempFile.Write _
"<html>" & _
"<head>" & _
"<title>Browse</title>" & _
"</head>" & _
"<body>" & _
"<input type='file' id='f' />" & _
"<script type='text/javascript'>" & _
"var f = ElementById('f');" & _
"f.click();" & _
"var shell = new ActiveXObject('WScript.Shell');" & _
"shell.RegWrite('HKEY_CURRENT_USER\\Volatile Environment\\MsgResp', f.value);" & _
"window.close();" & _
"</script>" & _
"</body>" & _
"</html>"
tempFile.Close
shell.Run tempFolder & "\" & tempName & ".hta", 0, True
BrowseForFile = shell.RegRead("HKEY_CURRENT_USER\Volatile Environment\MsgResp")
shell.RegDelete "HKEY_CURRENT_USER\Volatile Environment\MsgResp"
End Function
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论