'腳本說明 
'code by NP 
'outDateFile變量為要寫入的數據庫名字 
'Tables變量為Access數據庫中的表名 
'ROW變量為Access數據庫中的列名 
'Excel中的數據，直接為要寫入的數據，不需要標題一類的 
'例如：要寫入數據庫的列名為 
' 系別|班別|姓名|學號|性別|政治面貌|出生年月|身份證號碼|家庭地址|生源地畢業學校 
'而Excel文件中，只需要以下面的例子開頭就行了 
' 城建系|城建0001|韋XX|071010100111|女|團員|1981/11|451111111111111111|廣西xxxxxxxxx|xxxx學校 
'數據和列名要對的上號！ 
'腳本直接雙擊，更具提示操作 
If WScript.Arguments.Count > 0 Then InXlsFile = WScript.Arguments(0) 
If InXlsFile = "" Then 
InXlsFile = CreateObject("Excel.Application").GetOpenFilename("Excel Files (*.xls), *.xls") 
If VarType(Filename) = vbBoolean Then 
Wscript.Echo "Excel2Access。" & vbCr & vbLf & vbCr & vbLf & "用法: Excel2Access filename.xls 或在對話框中打開Excel文件。" 
WScript.Quit 
End If 
End If 
outDateFile="Excel2Access.mdb" '要轉換的數據庫名字 
Tables="學生信息表" '要創建以及寫入的表名 
Row="系別,班別,姓名,學號,性別,政治面貌,出生年月,身份證號碼,家庭地址,生源地畢業學校" '要創建以及寫入的列名,用逗號隔開 
Set Fso=CreateObject("Scripting.FileSystemObject") 
If Fso.FileExists(outDateFile) Then 
Call Writemdb 
Else 
Set DB = CreateObject("ADOX.Catalog") 
DB.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&outDateFile) 
Set ADOXTable = CreateObject("ADOX.Table") 
ADOXTable.Name = Tables 
For Each s In Split(Row, ",", -1, 1) 
ADOXTable.Columns.Append s,202 ' 字符串 
Next 
DB.Tables.Append ADOXTable 
Set DB=Nothing 
Call Writemdb 
End If 
Set Fso = Nothing 
Sub Writemdb() 
Set objExcel = CreateObject("Excel.Application") 
Set objWorkbook = objExcel.Workbooks.Open(InXlsFile) 
Set Conn=CreateObject("ADODB.Connection") 
ConnStr="DBQ="&outDateFile&";Driver={Microsoft Access Driver (*.mdb)};" 
Conn.Open ConnStr 
Rows=objExcel.ActiveSheet.UsedRange.Rows.Count 
Columns=objExcel.ActiveSheet.UsedRange.Columns.Count 
For i= 1 To rows 
tmp="" 
For j =1 To Columns 
If Len(objExcel.Cells(i,j).Value) <> 0 Then 
If j<>Columns Then 
tmp=tmp&"'"&objExcel.Cells(i,j).Value&"'," 
Else 
tmp=tmp&"'"&objExcel.Cells(i,j).Value&"'" 
'wscript.Echo "Insert Into "&Tables&"("&row&") Values("&tmp&")" 
Conn.Execute "Insert Into "&Tables&"("&Row&") Values("&tmp&")" 
End If 
Else 
Exit For 
End If 
Next 
Next 
objWorkbook.Close 
objExcel.Quit 
Conn.Close 
Set Conn=Nothing 
Set objWorkbook=Nothing 
Set objExcel=Nothing 
wscript.Echo "處理完畢，請檢查是否正常導入" 
End Sub