form1.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4005
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5940
   LinkTopic       =   "Form1"
   ScaleHeight     =   4005
   ScaleWidth      =   5940
   StartUpPosition =   3  '窗口缺省
   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        =   "Form1.frx":0000
      Left            =   120
      List            =   "Form1.frx":0002
      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 = "Form1"
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
        'sql = "INSERT INTO TestValues VALUES  ( " & "'" & new_value & "'" & ")"
        sql = "INSERT INTO  TestValues(datapoint,datasecond,sex) 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
     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