有没有其它办法了？？？？？？？？？？

这段程序导入三万多条记录要十多分钟，还有没有更快的办法，就像access自带导入程序一样（<1秒钟）快的办法，请指教一下。
Private Sub Command1_Click()
        Set conn = CreateObject("adodb.connection")
        dbpath = "d:\vb_excel\report.mdb"
        conn.Open ("driver={Microsoft Access Driver (*.mdb)};Set OLEDB:Allow Zero Length;dbq=" & dbpath)
        
        Set xlapp = CreateObject("Excel.Application")
        strsource = "d:\vb_excel\report.csv"
        Set xlBook = xlapp.Workbooks.Open(strsource)
        Set xlsheet = xlBook.Worksheets(1)
        
        Set Rs = CreateObject("adodb.recordset")
        sql = "select  * from report"
        Rs.Open sql, conn, 3, 3
        
        I = 7
        Do While I > 0 And xlsheet.Cells(I, 7) <> ""
           Rs.addnew
                Rs("date") = xlsheet.Cells(I, 1)
                Rs("Keyword") = xlsheet.Cells(I, 2)
                Rs("Keyword Matching") = xlsheet.Cells(I, 3)
                Rs("Keyword Status") = xlsheet.Cells(I, 4)
                Rs("Destination URL") = xlsheet.Cells(I, 5)
                Rs("Ad Group") = xlsheet.Cells(I, 6)
                Rs("Campaign") = xlsheet.Cells(I, 7)
                Rs("Maximum CPC") = xlsheet.Cells(I, 8)
                Rs("Impressions") = xlsheet.Cells(I, 9)
                Rs("Clicks") = xlsheet.Cells(I, 10)
                Rs("CTR") = xlsheet.Cells(I, 11)
                Rs("Avg CPC") = xlsheet.Cells(I, 12)
                Rs("Cost") = xlsheet.Cells(I, 13)
                Rs("Avg Position") = xlsheet.Cells(I, 14)
            Rs.Update
            
             I = I + 1
        Loop
        conn = Nothing
        xlapp.Quit
End Sub