Public 
 ExcelTable 
 As 
 Workbook  
 'excel 工作表对象
 
 
 Private 
 TextBoxA() 
 As 
 Control      
 '以编辑框为基础动态构造数据网格
 
 
 Private 
 FormWidth 
 As 
 Integer       
 '窗体宽度
 
 
 '以下子程序是用来建立数据网格
 
 
 Sub 
 CreateGrid(No, Data)
 
 
     
 For 
 i = 1 
 To 
 CInt
 (UBound(Data, 1))
 
 
         
 For 
 j = 1 
 To 
 CInt
 (UBound(Data, 2))
 
 
             
 Set 
 a = Form1.Controls.Add(
 "VB.TextBox"
 , 
 "textbox" 
 & 
 CStr
 (i) & 
 CStr
 (j) & 
 CStr
 (No))
 
 
             
 ReDim 
 TextBoxA(1 
 To 
 i, 1 
 To 
 j)  
 '重新定义动态数组！
 
 
             
 Set 
 TextBoxA(i, j) = a
 
 
             
 With 
 TextBoxA(i, j)            
 '设置文本框属性
 
 
                 
 .Text = Data(i, j)
 
 
                 
 .Visible = 
 True
 
 
                 
 .Height = 200
 
 
                 
 .Width = 500
 
 
                 
 .Top = .Height * (i - 1)
 
 
                 
 .Left = .Width * (j - 1) + FormWidth
 
 
             
 End 
 With
 
 
         
 Next
 
 
     
 Next
 
 
    
 
 
 End 
 Sub
 

   
 
 
 Private 
 Sub 
 Command1_Click()
 
 
     
 Set 
 ExcelTable = CreateObject(
 "Excel.sheet"
 ) 
 '建立对象实例
 
 
     
 ExcelTable.Application.Workbooks.Open (App.Path + 
 "\address.xls"
 ) 
 '打开数据文档address.xls
 
 
     
 For 
 i = 1 
 To 
 ExcelTable.Application.Worksheets.Count    
 '获得工作表数目
 
 
         
 Data = ExcelTable.Application.Worksheets(i).UsedRange.Value   
 '获取每个工作表的数据
 
 
         
 DataType = VarType(Data)      
 '跳过没有数据的空表
 
 
         
 Select 
 Case 
 DataType
 
 
         
 Case 
 vbArray + vbVariant
 
 
             
 Call 
 CreateGrid(i, Data)   
 '传递数据,建立以文本框为基础的数据网格
 
 
         
 Case 
 vbEmpty
 
 
         
 End 
 Select
 
 
     
 Next
 
 
 End 
 Sub

添加一个按钮和CommonDialog控件 如下图
 工程引用如下图
 
 源代码:
 
Private Sub Command1_Click()
     
     Dim sourceFilePath As String
     Me.CommonDialog1.Filter = "Excel (*.xls;*.xlsx)|*.xls;*.xlsx|" '过滤文件
     Me.CommonDialog1.FilterIndex = 2
     Me.CommonDialog1.ShowOpen
     If Me.CommonDialog1.FileName <> "" Then
        sourceFilePath = Me.CommonDialog1.FileName  '获取文件路径
        MsgBox sourceFilePath
     Else
        MsgBox "未选择文件"
        Exit Sub
     End If
     
     Dim rs As ADODB.Recordset
     Set rs = GetExcelRs(sourceFilePath, "sheet1") '调用方法
     MsgBox rs.Fields(0)
End Sub
 
'连接Excel方法**
 
Function GetExcelRs(ByVal sFile As String, Optional ExcelSheetName As String = "sheet1", Optional ErrInfo As String) As ADODB.Recordset

   On Error GoTo Err
   Dim rs As ADODB.Recordset
   Set rs = New ADODB.Recordset
   Dim ConnStr As String
   Dim sql As String

   ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source = " & sFile & ";Extended Properties ='Excel 12.0;HDR=YES;IMEX=1'"  '调用oledb连接，并将Excel表格中的首行做为标题行

   rs.Open "SELECT * FROM [" & ExcelSheetName & "$]", ConnStr, 1, 3
   Set GetExcelRs = rs
   Set rs = Nothing
   Exit Function
Err:
   ErrInfo = Err.Description
   MsgBox ErrInfo
End Function
 
注意：rs.open语句里的$符号缺失会报"Microsoft Access数据库引擎找不到对象sheet1…"
 

 
VB6操作EXCEL导入数据库
 
Private Function FunImpExcel(ByVal strFilePath As String) As Integer
 
'Excel文件格式
 
'第一行为表名，第二行为列名，其余行均为数据
 
On Error GoTo hErr
 
Dim objConn As New ADODB.Connection
 
Dim objRS As New ADODB.Recordset
 
If Dir(strFilePath) = "" Then
 
MsgBox "文件不存在",vbCritical,"错误"
 
Exit Function
 
End If
 
'定义Excel对象
 
Dim xlsApp As Object
 
Dim xlsWb As Object
 
Dim xlsWs As Object
 
Set xlsApp = CreateObject("Excel.Application") '建立excel对象
 
Set xlsWb = xlsApp.Workbooks.Open(strFilePath) '要打开的文档路径
 
Set xlsWs = xlsWb.Worksheets(1) '选工作表，有多张表时，可以参考此，变换序号指定不同的表
 
xlsWs.Activate
 
xlsApp.Visible = false '隐藏，否则会在界面显示出来
 
'Excel表格的行数和列数
 
Dim iRowCnt As Integer
 
Dim iColCnt As Integer
 
iRowCnt = xlsWs.UsedRange.Rows.Count '这个并不完全准确，在操作数据时要设置退出条件
 
iColCnt = xlsWs.UsedRange.Columns.Count'这个并不完全准确，在操作数据时要设置退出条件
 
'下面要根据具体的表格情况决定，这里前面两行是表名和列名
 
If iRowCnt <= 2 Then
 
MsgBox "没有需要导入的明细数据","错误"
 
GoTo hErr
 
End If
 
'从第3行开始是明细数据
 
For i = 3 To iRowCnt
 
'设置退出条件
 
If Trim$(xlsWs.Cells(i,3).Value) = "" Then
 
mdlPub.debug_print "on date found anymore:" & i
 
Exit For
 
End If
 
'第一条数据时，先打开数据库，这里是access
 
if 3 = i then
 
'数据库访问操作可以封装成一个公共的函数或过程
 
Dim strConn as String
 
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=true;Data Source=test.mdb"
 
objConn.CursorLocation = adUseClient
 
objConn.Open strConn
 
strSQL = "select * from [要导入的表名] where 1=2 "
 
objRS.CursorLocation = adUseClient
 
objRS.Open strSQL,objConn,adOpenKeyset,adLockOptimistic
 
End if
 
'新增一条记录，注意各个字段的数据类型匹配问题，
 
'最好全部统一先转化为字符串，再转化为对应的类型
 
objRS.AddNew
 
objRS.Fields("数据库列名１") = Trim(CStr(xlsWs.Cells(i,1).Value))
 
objRS.Fields("数据库列名2") = Trim(CStr(xlsWs.Cells(i,2).Value))
 
'.....
 
objRS.Fields("数据库列名n") = CLng(Trim(CStr(xlsWs.Cells(i,n).Value)))
 
'如果Excel列名与要导入的数据库列能按顺序一一对应，
 
'则可以按以下方式,但要解决不同字段的数据格式匹配问题，比较麻烦
 
'For j = 0 To RS.Fields.Count - 1
 
' RS.Fields(j) = Trim(CStr(xlsWs.Cells(i,1).Value))
 
'Next
 
'更新到数据库
 
objRS.Update
 
Next i
 
objRS.Close
 
objConn.Close
 
Set objRS = Nothing
 
Set objConn = Nothing
 
xlsWb.Close '关闭excel文件
 
xlsApp.Quit '退出excel
 
Set xlsWs = Nothing
 
Set xlsWb = Nothing
 
Set xlsApp = Nothing
 
FunImpExcel = 0'成功则返回０
 
Exit Function
 
hErr:
 
ImpExcelCertDtl = -１　'失败则返回１
 
If Not (xlsWb Is Nothing) Then xlsWb.Close '关闭文件
 
If Not (xlsApp Is Nothing) Then xlsApp.Quit
 
Set xlsWs = Nothing
 
Set xlsWb = Nothing
 
Set xlsApp = Nothing
 
MsgBox "文件导入失败","错误"
 
End Function
 
对于一个Excel文件中多个表格的情况，可以循环逐一导入。
 
为了方便，对于excel对象的定义可以明确一些，这样能自动弹出提示，方便编码。
 
如：
 
Dim xlsApp As New Excel.Application
 
Dim xlsWb As Excel.Workbook
 
Dim xlsWs As Excel.Worksheet
 
但这样定义时需要在工程中引入excel组件。
 
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
 
将数据导出至Excel
 
'-----------------
 
'从数据从数据库导出至excel，并弹出保存文件对话框
 
'-------------------
 
Private Function FunExpExcel()
 
On Error GoTo hErr
 
'注意引用excel组件，也可以直接定义为对象object
 
Dim xlsApp As New Excel.Application
 
Dim xlsWb As Excel.Workbook
 
Dim xlsWs As Excel.Worksheet
 
Dim strFilePath As String
 
Dim strFileNm As String
 
Dim iColIdx As Integer
 
Dim objTmp As Object
 
'创建excel
 
Set xlsApp = CreateObject("Excel.Application")
 
xlsApp.Visible = False
 
xlsApp.SheetsInNewWorkbook = 1 '定义表格个数
 
'新增一张表格， 这里可以增加多张表
 
Set xlsWb = xlsApp.Workbooks.Add
 
'指定sheet，指定第一张，如果有多张，可以具体指定哪一个
 
Set xlsWs = xlsWb.Worksheets(1)
 
'xlsApp.Visible = False
 
xlsWs.Activate
 
xlsWs.Select
 
'第一行为标题
 
xlsWs.Cells(1,1).Value = "表格标题"
 
'第二行为列名,第一列列名“序号”
 
xlsWs.Cells(2,1).Value = "序号"
 
....
 
xlsWs.Cells(2,n).Value = "序号"
 
'如果是datagrid，可以直接用对应的列名
 
'For iColIdx = 0 To Me.grdQryInst.Columns.Count - 1
 
' xlsWs.Cells(2,iColIdx + 2).Value = Me.datagrid1.Columns(iColIdx).Caption
 
'Next
 
'设置第一列序号为数字格式
 
xlsWs.Columns("A:A").NumberFormatLocal = "0_ "
 
'设置其它列为文本格式,函数NumToChar26能将数字转化为对应的excel列名，如2->B,3->C,自已实现
 
'xlsWs.Columns(NumToChar26(2) & ":" & NumToChar26(Me.datagrid1.Columns.Count)).NumberFormatLocal = "@"
 
'----这里打开数据库，查询数据略，自己实现，如果是datagrid,则可以按下面的方法
 
'Dim RS As ADODB.Recordset
 
'Set RS = Me.datagrid1.DataSource
 
'从第三行开始写明细数据
 
RS.MoveFirst
 
For iRowIdx = 0 To RS.RecordCount - 1
 
xlsWs.Cells(iRowIdx + 3,1).Value = CStr(iRowIdx + 1)
 
'对第一行，按顺序逐列写单元格
 
For iColIdx = 0 To RS.Fields.Count - 1
 
xlsWs.Cells(iRowIdx + 3,iColIdx + 2).Value = RS.Fields(iColIdx).Value
 
Next
 
RS.MoveNext
 
Next
 
'-----写完数据，下面设置导出excel格式
 
'标题格式设置
 
Set objTmp = xlsWs.Range(xlsWs.Cells(1,1),xlsWs.Cells(1,iColIdx + 2 - 1))
 
objTmp.Merge　'合并单元格
 
'标题排版
 
With objTmp
 
.HorizontalAlignment = xlCenter
 
.VerticalAlignment = xlCenter
 
End With
 
With objTmp.Font
 
.Name = "宋体"
 
.Size = 18
 
End With
 
'第2行开始，设置边框，字体与标题不同
 
Set objTmp = xlsApp.Range(xlsWs.Cells(2,xlsWs.Cells(iRowIdx + 3 - 1,iColIdx + 2 - 1))
 
With objTmp.Font
 
.Name = "宋体"
 
.Size = 10
 
.Underline = xlUnderlineStyleNone
 
.ColorIndex = xlAutomatic
 
End With
 
objTmp.Borders(xlDiagonalDown).LineStyle = xlNone
 
objTmp.Borders(xlDiagonalUp).LineStyle = xlNone
 
With objTmp.Borders(xlEdgeLeft)
 
.LineStyle = xlContinuous
 
.Weight = xlThin
 
.ColorIndex = xlAutomatic
 
End With
 
With objTmp.Borders(xlEdgeTop)
 
.LineStyle = xlContinuous
 
.Weight = xlThin
 
.ColorIndex = xlAutomatic
 
End With
 
With objTmp.Borders(xlEdgeBottom)
 
.LineStyle = xlContinuous
 
.Weight = xlThin
 
.ColorIndex = xlAutomatic
 
End With
 
With objTmp.Borders(xlEdgeRight)
 
.LineStyle = xlContinuous
 
.Weight = xlThin
 
.ColorIndex = xlAutomatic
 
End With
 
With objTmp.Borders(xlInsideVertical)
 
.LineStyle = xlContinuous
 
.Weight = xlThin
 
.ColorIndex = xlAutomatic
 
End With
 
With objTmp.Borders(xlInsideHorizontal)
 
.LineStyle = xlContinuous
 
.Weight = xlThin
 
.ColorIndex = xlAutomatic
 
End With
 
'设置列宽，自动扩展
 
For iColIdx = 1 To Me.grdQryInst.Columns.Count + 1
 
xlsWs.Columns(NumToChar26(iColIdx) & ":" &　NumToChar26(iColIdx)).EntireColumn.AutoFit
 
Next
 
'弹出保存文件对话框，要在窗体上增加commondialog控件，控件命名dlgFile
 
Me.dlgFile.DialogTitle = "保存至"
 
Me.dlgFile.Flags = &H200
 
Me.dlgFile.DefaultExt = ".xls"
 
Me.dlgFile.Filter = "Excel数据文件 *.xls|*.xls" '过滤器
 
Me.dlgFile.InitDir = App.Path
 
Me.dlgFile.FileName = strFileNm & ".xls"
 
Me.dlgFile.ShowSave
 
If Err <> 32755 Then strFilePath = dlgFile.FileName
 
If "" <> strFilePath Then
 
xlsWb.SaveAs strFilePath
 
Else
 
mdlPub.ShowInfo "文件未保存"
 
End If
 
xlsWb.Close
 
xlsApp.Quit
 
Set xlsWs = Nothing
 
Set xlsWb = Nothing
 
Set xlsApp = Nothing
 
FunExpExcel = 0 '成功则返回0
 
mdlPub.ShowInfo "已保存至" & strFilePath
 
Exit Sub
 
hErr:
 
FunExpExcel = -1'失败则返回1
 
If Err.Number <> 0 Then mdlPub.ShowErrMsg "导出错"
 
If Not (xlsWb Is Nothing) Then Set xlsWs = Nothing
 
If Not (xlsWb Is Nothing) Then
 
xlsWb.Close
 
Set xlsWb = Nothing
 
End If
 
If Not (xlsWb Is Nothing) Then
 
xlsApp.Quit
 
Set xlsApp = Nothing
 
End If
 
End Function
 
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
 
h注意，在使用VB操作excel过程中，对于excel对象的引用都要用到本地定义的excel三个变量xlsApp，xlsWb，xlsWs之一做前缀，否则， 会出现残留EXCEL进程的情况，下次操作EXCEL时会报错。原因是没有加本地定义的变量做前缀，而使用了EXCEl的全局变量形式，xlsWb.Close，xlsApp.Quit语句只是退出局部EXCEL，无法退出全局EXCEL。

其实不算原创，论坛里有人发的，我正好项目写到这里，缺的语句较多，无法运行，我补充了一下，可以简单的运行了，测试了一下，速度还不错。
 
VS2015可用，自己添加窗体和控件吧，只需要一个OpenFileDialog和Button，默认文件中带有字段名。
 
Public Class Form1
     Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

         Try

             Dim fileName As String

             OpenFileDialog1.ShowDialog()

             fileName = OpenFileDialog1.FileName

             '建立EXCEL连接，读入数据，支持 Microsoft Excel 2010

             Dim strConn As String = "Provider= Microsoft.Ace.OleDb.12.0;Data Source='" & fileName & "';Extended Properties=Excel 12.0;"

             '建立EXCEL连接，读入数据，支持 Microsoft Excel 2003

             'Dim strConn As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & fileName & "';Extended Properties=Excel 8.0;"

             Dim da As New OleDb.OleDbDataAdapter("SELECT * FROM [Sheet1$]", strConn)

             Dim ds As DataSet = New DataSet

             da.Fill(ds, "自己的数据表")

             Me.DataGridView1.DataSource = ds.Tables(0)

             If ds.Tables(0).Rows.Count > 0 Then

                 Dim strSql As String

                 Dim CnnStr As String = "server=localhost;database=自己的数据库;user id=sa;password=密码"

                 Dim conn As SqlClient.SqlConnection = New SqlClient.SqlConnection(CnnStr)

                 conn.Open()

                 Dim myCmd As SqlClient.SqlCommand

                 Dim i As Integer

                 For i = 0 To ds.Tables(0).Rows.Count - 1 Step i + 1

                     '根据自己的字段添加

                     strSql = "insert into 登录表 VALUES ('" + ds.Tables(0).Rows(i).Item(0).ToString + "','" +

                         ds.Tables(0).Rows(i).Item(1).ToString + "','" + ds.Tables(0).Rows(i).Item(2).ToString + "','" +

                         ds.Tables(0).Rows(i).Item(3).ToString + "')"

                     Application.DoEvents()                   

                     myCmd = New SqlClient.SqlCommand(strSql, conn)

                     myCmd.ExecuteNonQuery()                   

                 Next

                 MsgBox("导入保存成功！", 48, "提示")

             End If

         Catch ex As Exception

             MsgBox(ex.Message)

         End Try

     End Sub