excel.frm

有时候要将excel表格转换成access数据库,本程序可以轻松实现.

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form excel 
   Caption         =   "Excel转mdb数据库"
   ClientHeight    =   4080
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9210
   Icon            =   "excel.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4080
   ScaleWidth      =   9210
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame1 
      Height          =   3975
      Left            =   5880
      TabIndex        =   13
      Top             =   0
      Width           =   3135
      Begin VB.ListBox List3 
         Height          =   2400
         Left            =   240
         TabIndex        =   18
         Top             =   1440
         Width           =   2415
      End
      Begin VB.ComboBox Combo2 
         Height          =   300
         Left            =   1320
         TabIndex        =   17
         Text            =   "Combo2"
         Top             =   1080
         Width           =   1335
      End
      Begin VB.ComboBox Combo1 
         Height          =   300
         Left            =   240
         TabIndex        =   14
         Text            =   "Combo1"
         Top             =   1080
         Width           =   975
      End
      Begin VB.Label Label5 
         Caption         =   "数据字段："
         Height          =   255
         Left            =   1320
         TabIndex        =   16
         Top             =   720
         Width           =   1215
      End
      Begin VB.Label Label4 
         Caption         =   "数据表："
         Height          =   255
         Left            =   240
         TabIndex        =   15
         Top             =   720
         Width           =   975
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   2760
      Top             =   840
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command4 
      Caption         =   "<<"
      Height          =   495
      Left            =   2460
      TabIndex        =   10
      Top             =   2400
      Width           =   975
   End
   Begin VB.CommandButton Command3 
      Caption         =   ">>"
      Height          =   495
      Left            =   2460
      TabIndex        =   9
      Top             =   1560
      Width           =   975
   End
   Begin VB.ListBox List2 
      Height          =   2400
      Left            =   3480
      TabIndex        =   8
      Top             =   1440
      Width           =   2295
   End
   Begin VB.ListBox List1 
      Height          =   2400
      ItemData        =   "excel.frx":0442
      Left            =   120
      List            =   "excel.frx":0444
      TabIndex        =   7
      Top             =   1440
      Width           =   2175
   End
   Begin VB.CommandButton Command2 
      Caption         =   "…"
      Height          =   220
      Left            =   5320
      TabIndex        =   6
      Top             =   510
      Width           =   300
   End
   Begin VB.CommandButton Command1 
      Caption         =   "…"
      Height          =   220
      Left            =   5320
      TabIndex        =   5
      Top             =   145
      Width           =   300
   End
   Begin VB.TextBox txtAccessFile 
      Height          =   285
      Left            =   1560
      TabIndex        =   3
      Top             =   480
      Width           =   4095
   End
   Begin VB.CommandButton cmdLoad 
      Caption         =   "开始转换"
      Default         =   -1  'True
      Height          =   495
      Left            =   2460
      TabIndex        =   2
      Top             =   3240
      Width           =   975
   End
   Begin VB.TextBox txtExcelFile 
      Height          =   285
      Left            =   1560
      TabIndex        =   1
      Top             =   120
      Width           =   4095
   End
   Begin VB.Label Label2 
      Caption         =   "需转换的列："
      Height          =   375
      Left            =   3720
      TabIndex        =   12
      Top             =   960
      Width           =   1335
   End
   Begin VB.Label Label3 
      Caption         =   "Eexcl源的列表头："
      Height          =   375
      Left            =   240
      TabIndex        =   11
      Top             =   960
      Width           =   1815
   End
   Begin VB.Label Label1 
      Caption         =   "目标数据库mdb"
      Height          =   255
      Index           =   1
      Left            =   120
      TabIndex        =   4
      Top             =   480
      Width           =   1335
   End
   Begin VB.Label Label1 
      Caption         =   "要转换的Eexcl"
      Height          =   255
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1335
   End
End
Attribute VB_Name = "excel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'download at: http://vb.cn99.com

Option Explicit
Dim lieshu As Variant
Dim lieshu1 As Variant
Dim lieshu2 As Variant
Dim shu As Integer
Dim shu1 As Integer
Dim shu2 As Integer
Dim zst As String
Dim zst1 As String
Dim zst2 As String
Private Sub cmdLoad_Click()
Dim excel_app As Object
Dim excel_sheet As Object
Dim db As Database
Dim new_value As String
Dim new_value1 As String
Dim new_value2 As String
Dim row2 As Integer
Dim row As Integer
Dim row1 As Integer
    Screen.MousePointer = vbHourglass
    DoEvents

    ' Create the Excel application.
    Set excel_app = CreateObject("Excel.Application")

    ' Uncomment this line to make Excel visible.
'    excel_app.Visible = True

    ' Open the Excel spreadsheet.
    excel_app.Workbooks.Open FileName:=txtExcelFile.Text

    ' Check for later versions.
    If Val(excel_app.Application.Version) >= 8 Then
        Set excel_sheet = excel_app.ActiveSheet
    Else
        Set excel_sheet = excel_app
    End If

    ' Open the Access database.
    Set db = OpenDatabase(txtAccessFile.Text)
     zst1 = List2.List(1)
     lieshu1 = Mid(Right(zst1, 3), 2, 1)
     shu1 = lieshu1
    zst = List2.List(0)
    lieshu = Mid(Right(zst, 3), 2, 1)
    shu = lieshu
    zst2 = List2.List(2)
    lieshu2 = Mid(Right(zst2, 3), 2, 1)
    shu2 = lieshu2
    ' Get data from the Excel spreadsheet and insert
    ' it into the TestValues table.
    row = 2
    row1 = 2
    row2 = 2
    Do
        ' Get the next value.
        new_value = Trim$(excel_sheet.Cells(row, shu))
        new_value1 = Trim$(excel_sheet.Cells(row1, shu1))
        new_value2 = Trim$(excel_sheet.Cells(row2, shu2))
        ' See if it's blank
        If Len(new_value) = 0 Then Exit Do
        If Len(new_value1) = 0 Then Exit Do
        If Len(new_value2) = 0 Then Exit Do
        ' Insert the value into the database.
        Dim sql As String
        Dim Ss As String
        
        'sql = "INSERT INTO TestValues VALUES  ( " & "'" & new_value & "'" & ")"
        'sql = "INSERT INTO  base(班级,姓名,性别) VALUES  ( " & "'" & new_value & "'" & " ," & "'" & new_value1 & "'" & " ," & "'" & new_value2 & "'" & ")"
        sql = "INSERT INTO  base( " & Ss & " ,姓名,性别) VALUES  ( " & "'" & new_value & "'" & " ," & "'" & new_value1 & "'" & " ," & "'" & new_value2 & "'" & ")"
        db.Execute sql
        
        row = row + 1
        row1 = row1 + 1
        row2 = row2 + 1
    Loop
    
    
   
     
    ' Close the database.
    db.Close
    Set db = Nothing

    ' Comment the rest of the lines to keep
    ' Excel running so you can see it.

    ' Close the workbook without saving.
    excel_app.ActiveWorkbook.Close False

    ' Close Excel.
    excel_app.Quit
    Set excel_sheet = Nothing
    Set excel_app = Nothing

    Screen.MousePointer = vbDefault
    MsgBox "转换了" & Format$(row - 2) & " 条记录！"
End Sub

Private Sub Command1_Click()
CommonDialog1.ShowOpen
txtExcelFile.Text = CommonDialog1.FileName
Command2.Enabled = True
txtAccessFile.Enabled = True
List1.Clear
List2.Clear
End Sub

Private Sub Command2_Click()
CommonDialog1.ShowOpen
txtAccessFile.Text = CommonDialog1.FileName



    Dim excel_app As Object
Dim excel_sheet As Object
Dim db As Database
Dim new_value As String
Dim row As Integer

    Screen.MousePointer = vbHourglass
    DoEvents

    ' Create the Excel application.
    Set excel_app = CreateObject("Excel.Application")

    ' Uncomment this line to make Excel visible.
'    excel_app.Visible = True

    ' Open the Excel spreadsheet.
    excel_app.Workbooks.Open FileName:=txtExcelFile.Text

    ' Check for later versions.
    If Val(excel_app.Application.Version) >= 8 Then
        Set excel_sheet = excel_app.ActiveSheet
    Else
        Set excel_sheet = excel_app
    End If

    ' Open the Access database.
    Set db = OpenDatabase(txtAccessFile.Text)

    ' Get data from the Excel spreadsheet and insert
    ' it into the TestValues table.
    row = 1
    Do
        ' Get the next value.
        new_value = Trim$(excel_sheet.Cells(1, row))

        ' See if it's blank.
        If Len(new_value) = 0 Then Exit Do
        
        ' Insert the value into the database.
       List1.AddItem new_value & "(" & row & ")"
    
    
        row = row + 1
    Loop

    ' Close the database.
    db.Close
    Set db = Nothing

    ' Comment the rest of the lines to keep
    ' Excel running so you can see it.

    ' Close the workbook without saving.
    excel_app.ActiveWorkbook.Close False

    ' Close Excel.
    excel_app.Quit
    Set excel_sheet = Nothing
    Set excel_app = Nothing
    
    
    Dim rsSchema As ADODB.Recordset
Dim nCount As Integer
Dim newTableName As String
Dim Password As String

        Set rsSchema = dbobj.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
        If Not rsSchema Is Nothing Then
            Do While Not rsSchema.EOF
                If UCase(Left(rsSchema!Table_name, 4)) <> "MSYS" Then
                    If UCase(Left(rsSchema!Table_name, 11)) <> "SWITCHBOARD" Then
                        newTableName = rsSchema!Table_name
                        cmbTables.AddItem newTableName
                        frmPurgeDate.cmbTables.AddItem newTableName
                        frmRenameTable.cmbTables.AddItem newTableName
                    End If
                End If
                rsSchema.MoveNext
            Loop
            cmbTables.AddItem DEF_CUSTOM_SQL
        End If
  
    rsSchema.Close
     Screen.MousePointer = vbDefault
End Sub

Private Sub Command3_Click()
If List1.Text = "" Then
Else
List2.AddItem List1.Text
End If
End Sub

Private Sub Command4_Click()
Dim index1 As Integer
index1 = List2.ListIndex
If index1 >= 0 Then List2.RemoveItem index1
End Sub

Private Sub Command5_Click()

End Sub

' Note that this project contains a reference to
' Microsoft DAO 3.51 Object Library.
Private Sub Form_Load()
Command2.Enabled = False
txtAccessFile.Enabled = False
Dim file_path As String

    file_path = App.Path
    If Right$(file_path, 1) <> "\" Then file_path = file_path & "\"
    txtExcelFile.Text = file_path & "XlsToMdb.xls"
    txtAccessFile.Text = file_path & "XlsToMdb.mdb"
    

    'MsgBox "Copied " & Format$(row - 1) & " values."
End Sub