access读取EXCEL文件,并根据动态生成表，完成报表的导入

Option Compare DatabasePublic sheetid As String '报表IDPublic temp As String '获取年月时分秒Public tmpI As Integer '对应EXCEL行Public tmpJ As Integer '对应EXCEL列Public XlsApp As ObjectPublic XlsWorkbook As ObjectPublic XlsWorkSheet As Object'Public Rst As New ADODB.Recordset'Public
Rcount As Integer'Public Fcount As Integer'Public CheckBoolean As Boolean '用于判断是否有CSV存在'Public TotalRows As Integer'Public RpId As String'Public RpName As StringPublic Conn_EXCEL As New ADODB.ConnectionPublic Rs_EXCEL As New ADODB.RecordsetPublic FileNameTmp
As String'==============================================================================='-名称: 报表生成,记录写入'-功能描述: EXCEL文件中查找对应的报表ID，并进行读取'-返回参数说明: TempSheetId：报表ID'-使用语法示例: For ; EXCEL.Application;ADO'-参考:'-使用注意: 需要引用ADO或更高版本'-兼容性: XP,2003'-作者: 芦春堂 luke (ACCESS技巧网
Http://www.mdbtip.com)'-更新日期： 2011年2月19日'===============================================================================Public Sub ReadEXCEL(TempSheetId As String) On Error Resume Next If fExist = True Then Dim TemXls As String Dim I, ii, T1 As Long Dim TimeStr
As String Dim J, JJ As Long Dim ssql As String Dim intJ As Long Dim intI As Long Dim objSheet As Object Dim SheetNb As Long Dim Rst As New ADODB.Recordset xlsBakPath = Path_XlsBak Dim tmpSheet As String Dim fso As New FileSystemObject Dim Nub As Long Dim idCount
As Long Dim lngRows As Long Dim idCountStr As String idCount = 0 Dim txtId_Name As String Dim txtId As String Dim ItmCount, ItmCount1 As Long Dim txtLine As String ' Dim tCount As Integer ' ReDim Preserve aryFileData() Dim FileLog As String FileLog = path_log
& "ReadCSV_" & Format(Now(), "yyyymmddhhmmss") & ".LOG" Open FileLog For Output As #1 TimeStr = Format(Now, "yyyymmddhhmmss") '获取时间，作为新的报表名称之一 temp = TimeStr sheetid = TempSheetId If err.Number <> 3376 Then DoCmd.SetWarnings False DoCmd.RunSQL "drop table
tmp1" DoCmd.SetWarnings True Else Print #1, err.Description, err.Number, Now() End If If err.Number = 3376 Then Print #1, err.Description, err.Number, Now() GoTo CZ End IfCZ: '查找CSV文件,并读取文件 With Application.FileSearch .NewSearch .LookIn = path_csv ' .FileName
= "*.csv" .FileName = "*.xls" .Execute If .FoundFiles.Count >= 1 Then For Nub = 1 To .FoundFiles.Count If InStr(.FoundFiles(Nub), "" & TempSheetId & "") > 0 Then If InStr(.FoundFiles(Nub), "Finished.xls") = 0 Then '判断是否已经被读取过 txtId = Mid(.FoundFiles(Nub),
InStr(.FoundFiles(Nub), "" & TempSheetId & ""), InStr(.FoundFiles(Nub), ".xls") - InStr(.FoundFiles(Nub), "" & TempSheetId & "")) txtId_Name = txtId & "_" & Format(Now(), "yyyymmddhhmmss") & "_" & "Finished.xls" '新的命名 FileNameTmp = .FoundFiles(Nub) Call CloseEXCELWorkbooks(.FoundFiles(Nub))
Set XlsApp = CreateObject("EXCEL.Application") Set XlsWorkbook = XlsApp.Workbooks.Open(.FoundFiles(Nub)) '打开指定的EXCEL Set objSheet = XlsWorkbook.Sheets(1) '默认第一个,这里不做循环处理 '取得数据行数,由于第一列为标题，所以有效行数需要减1 ' For Each objSheet In XlsWorkbook.Worksheets ' If XlsApp.WorksheetFunction.CountA(objSheet.Range("A1"))
> 0 Then ' intJ = 1 '将工作表中的第一行作为列标题保存到集合变量 '保存格式为： 工作表名称 + 列标题（Sheet1|字段1） Do Until objSheet.Cells(1, intJ) = "" If idCountStr = "" Then idCountStr = objSheet.Cells(1, intJ) & " varchar(255)" Else idCountStr = idCountStr & "," & objSheet.Cells(1, intJ) & "
varchar(255)" End If intJ = intJ + 1 Loop ' End If objSheet.Select objSheet.Cells.SpecialCells(11).Select ' Next lngRows = XlsApp.ActiveCell.Row - 1 ' 根据分割后的行数据自动创建临时 Rst.Open "tmp1", CurrentProject.Connection, adOpenKeyset, adLockReadOnly If err.Number =
-2147217900 Then '该表不存在时自动创建表 Print #1, "Open tmp1 fail,it will create table tmp1 " & err.Number, Now() DoCmd.SetWarnings False DoCmd.RunSQL "create table tmp1(" & idCountStr & ")" DoCmd.SetWarnings True End If Rst.Close Set Rst = Nothing Rst.Close Rst.Open
"tmp1", CurrentProject.Connection, adOpenKeyset, adLockOptimistic '保存记录到临时表 For ItmCount1 = 1 To lngRows Rst.AddNew For ItmCount = 1 To intJ Rst(ItmCount - 1) = objSheet.Cells(ItmCount1 + 1, ItmCount) Next ItmCount ' ItmCount1 = ItmCount1 + 1 Next ItmCount1
Rst.Update Rst.Close Set Rst = Nothing Set XlsApp = Nothing Set XlsWorkbook = Nothing Set XlsWorkSheet = Nothing Rs_EXCEL.Close Set Rs_EXCEL = Nothing Conn_EXCEL.Close Set Conn_EXCEL = Nothing Call CloseEXCELWorkbooks(.FoundFiles(Nub)) Print #1, "Table Data
Save OK", Now() Name "" & .FoundFiles(Nub) & "" As path_csv & txtId_Name '对读取完的CSV重新命名 Print #1, "ReName " & .FoundFiles(Nub) & " " & path_csv & txtId_Name, Now() fso.MoveFile path_csv & txtId_Name, path_csvbak '将重命名后的CSV文件转入备份文件夹 Print #1, "moveFile " & path_csv
& txtId_Name & " " & path_csvbak, Now() idCount = idCount + 1 End If Print #1, "Nubmer: " & idCount & " CSV: ", path_csv & txtId_Name, Now() Print #1, " " '写入LOG End If Next Nub Else MsgBox "No CSV", vbCritical, "Message" CheckBoolean = False Print #1, "No
CSV,CheckBoolean = False ", Now() Exit Sub End If MsgBox "it has succeed " & idCount & " CSV", vbInformation + vbExclamation, "message" Print #1, "it has succeed " & idCount & " CSV", Now() Close #1 If idCount >= 1 Then CheckBoolean = True Else CheckBoolean
= False End If idCount = 0 End With Rst.Close Set Rst = Nothing Rs_EXCEL.Close Set Rs_EXCEL = Nothing Conn_EXCEL.Close XlsWorkbook.Close XlsApp.Quit Set Conn_EXCEL = Nothing Set XlsApp = Nothing Set XlsWorkbook = Nothing End IfEnd Sub