使用VB里的Jet IISAM Drivers(DAO) 有示例:(自己看看,我没有时间详细说明了) Dim xlsCn As New ADODB.Connection Dim xlsRs As New Recordset
On Error Resume Next Err.Clear xlsCn.CursorLocation = adUseClient xlsCn.Open "provider=microsoft.jet.oledb.4.0;" & _ "data source=" & Text1.Text & ";" & _ "extended properties=""excel 8.0;hdr=yes;"";" '注意: "hdr=yes"表示在第一行中是行标题,在provider中将不把第一行包括入recordset中 xlsRs.Open "Select * from [" & Replace(cboSheetName.Text, "'", "") & "]", xlsCn, adOpenKeyset, adLockOptimistic If Err.Number <> 0 Then MsgBox "打不开" & Text1.Text & "文件中的工作表" & cboSheetName.Text, vbCritical, "错误" GoTo ExitCode End If
'MsgBox "共有记录" & xlsRs.RecordCount & "需要导入", vbInformation, "提示信息" If xlsRs.RecordCount = 0 Then MsgBox "该工作表为空,您不必导入空表.", vbInformation, "提示信息" 'GoTo ExitCode End If listSource.Clear For i = 0 To xlsRs.Fields.Count - 1 listSource.AddItem xlsRs.Fields(i).name listSource.ItemData(i) = -1 listSource.Selected(i) = False For j = 0 To lstDes.ListCount - 1 If lstDes.list(j) Like listSource.list(i) Then lstDes.ItemData(j) = i listSource.ItemData(i) = 0 listSource.Selected(i) = True End If Next
Next
ExitCode: Set xlsRs = Nothing Set xlsCn = Nothing End SubPrivate Sub cmdLink_Click() Dim i As Integer For i = 0 To lstDes.ListCount - 1
If lstDes.Selected(i) And listSource.ListIndex <> -1 Then lstDes.ItemData(i) = listSource.ListIndex listSource.ItemData(listSource.ListIndex) = 0 lstDes.Selected(i) = True End If Next End SubPrivate Sub cmdOpen_Click()
Dim i As Integer cmdDlg.Filter = "(Excel文件)|*.xls" cmdDlg.ShowOpen If cmdDlg.FileName = "" Then Exit Sub
Text1.Text = cmdDlg.FileName
'取得工作表名 On Error Resume Next Dim db As Database Set db = OpenDatabase(Text1.Text, False, False, "Excel 8.0;") cboSheetName.Clear For i = 0 To db.TableDefs.Count - 1 cboSheetName.AddItem db.TableDefs(i).name Next cboSheetName.ListIndex = 0 db.Close Set db = Nothing
End Sub Private Sub cmdUnlink_Click() Dim i As Integer For i = 0 To lstDes.ListCount - 1
If lstDes.Selected(i) And listSource.ListIndex <> -1 Then lstDes.ItemData(i) = -1 lstDes.Selected(i) = False End If Next End SubPrivate Sub Command1_Click() Dim getSid As Long Dim SucCustomerCount, SucCustomerAdd As Long '记录成功的添加的客户 Dim SucCatactorCount, SucCatactorAdd As Long '记录成功的添加的联系人 Dim GetEmail, CustomerName As String SucCustomerCount = 0 SucCustomerAdd = 0 '********************** SucCatactorCount = 0 SucCatactorAdd = 0 ' On Error Resume Next '判断所有选中的字段是否都关联了 j = 0 For i = 0 To listSource.ListCount - 1 If listSource.ItemData(i) = -1 And listSource.Selected(i) = True Then MsgBox "请确认您设置好了原工作表和数据库中字段的对应关系!!!", vbInformation, "提示信息" Exit Sub End If j = j + 1 Next If j = 0 Then MsgBox "你没有选取任何字段", vbInformation, "提示信息" Exit Sub End If
If checknull = False Then MsgBox "企业名称还没有对应的Excel字段", vbInformation, "提示信息" Exit Sub End If
If MsgBox("请确认要将文件" & Text1.Text & "导入到" & cboemployee.Text & ",客户状态是" & cboCustomerStatus.Text, vbYesNo, "提示信息") = vbNo Then Exit Sub If MsgBox("请确认要将文件" & Text1.Text & "导入到" & cboemployee.Text & ",客户状态是" & cboCustomerStatus.Text, vbYesNo, "请您再次确认") = vbNo Then Exit Sub
Screen.MousePointer = 13 Me.Enabled = False '开始导入数据 Dim xlsCn As New ADODB.Connection 'ExCel连接 Dim xlsRs As New Recordset Dim rs As New Recordset xlsCn.CursorLocation = adUseClient xlsCn.Open "provider=microsoft.jet.oledb.4.0;" & _ "data source=" & Text1.Text & ";" & _ "extended properties=""excel 8.0;hdr=yes;"";" '注意: "hdr=yes"表示在第一行中是行标题,在provider中将不把第一行包括入recordset中 xlsRs.Open "Select * from [" & Replace(cboSheetName.Text, "'", "") & "]", xlsCn, adOpenKeyset, adLockOptimistic MsgBox "共有" & xlsRs.RecordCount & "条记录需要写入" '数据库连接, Set Conn = New ADODB.Connection Conn.CursorLocation = adUseClient Conn.Open ConnStr While Not xlsRs.EOF DoEvents DoEvents StatusBar1.SimpleText = "第" & xlsRs.AbsolutePosition & "条纪录/总共" & xlsRs.RecordCount Set rs = New Recordset '************************************************************************************ Err.Clear '写入客户的信息开始,如果企业名称不为空才写入 CustomerName = "" If xlsRs(GetExcel("CustomerName")) <> "" Or Not IsNull(xlsRs(GetExcel("CustomerName"))) Then CustomerName = xlsRs(GetExcel("CustomerName")) '客户名称不为空
Else If GetExcel("Email") <> "" Then CustomerName = CustomerName & xlsRs(GetExcel("Email")) End If If GetExcel("FirstName") <> "" And GetExcel("LastName") <> "" Then CustomerName = CustomerName & xlsRs(GetExcel("FirstName")) & xlsRs(GetExcel("LastName")) End If
End If
If CustomerName <> "" Then rs.Open "select * from OF_Customer where CustomerName='" & CustomerName & "'", Conn, adOpenKeyset, adLockOptimistic If rs.EOF Then rs.AddNew SucCustomerAdd = SucCustomerAdd + 1 End If For i = 0 To rs.Fields.Count - 1 '取得该字段的值 For j = 0 To lstDes.ListCount - 1 If Field2En(Trim(lstDes.list(j))) = rs(i).name And rs(i).DefinedSize <> 4 And lstDes.ItemData(j) > -1 Then rs(i) = Trim(xlsRs(listSource.list(lstDes.ItemData(j)))) End If Next Next rs("CustomerName") = CustomerName rs("CustomerStatus") = cboCustomerStatus.Text rs.Update getSid = rs("CustomerID") GetEmail = Trim(CNull(rs("Email"))) 'MsgBox getSid rs.Close If Err.Number = 0 Then SucCustomerCount = SucCustomerCount + 1 '写入客户信息结束 '************************************************************************************ '写入联系人信息 Err.Clear rs.Open "select * from OF_Contactor where CustomerId=" & getSid & "and Email='" & GetEmail & "'", Conn, adOpenStatic, adLockOptimistic If rs.EOF Then rs.AddNew rs("Email") = GetEmail rs("CustomerId") = getSid SucCatactorAdd = SucCatactorAdd + 1 End If For i = 0 To rs.Fields.Count - 1 '取得该字段的值 For j = 0 To lstDes.ListCount - 1 If Field2En(lstDes.list(j)) = rs(i).name And (rs(i).DefinedSize <> 4 Or LCase(rs.Fields(i).name) = LCase("EmployeeId")) And lstDes.ItemData(j) > -1 Then rs(i) = Trim(Left(xlsRs(listSource.list(lstDes.ItemData(j))), rs(i).DefinedSize))
End If Next Next
'默认将联系人分配给职员 If cboemployee.ItemData(cboemployee.ListIndex) <> 0 Then rs("EmployeeId") = cboemployee.ItemData(cboemployee.ListIndex) End If rs("Email") = GetEmail
rs.Update
' MsgBox getSid rs.Close
'************************************************************************************ If Err.Number = 0 Then SucCatactorCount = SucCatactorCount + 1 End If xlsRs.MoveNext Wend Set rs = Nothing Set Conn = Nothing Set xlsRs = Nothing Set xlsCn = Nothing MsgBox "导入成功!!", vbInformation, "提示信息" MsgBox "成功的加入" & SucCustomerAdd & "个客户资料和" & SucCatactorAdd & "个联系人资料" & vbCrLf & ",修改了" & _ "修改了" & SucCustomerCount - SucCustomerAdd & "个客户资料和" & SucCatactorCount - SucCatactorAdd & "个联系人资料" StatusBar1.SimpleText = "完成了任务!!" Screen.MousePointer = vbDefault Me.Enabled = True End Sub
先用ado连接 然后和数据库一样的操作
(不过没有完全理解你的意思)
crm系统是sql数据库,crm里要看到并分析excel导入的数据,在程序中怎么实现?
关注中
他知道的话,那就一大堆话!
^_^
[email protected]
哪真是太感谢了,有热心人帮助,不管有没有用都要报答
有示例:(自己看看,我没有时间详细说明了)
Dim xlsCn As New ADODB.Connection
Dim xlsRs As New Recordset
On Error Resume Next
Err.Clear
xlsCn.CursorLocation = adUseClient
xlsCn.Open "provider=microsoft.jet.oledb.4.0;" & _
"data source=" & Text1.Text & ";" & _
"extended properties=""excel 8.0;hdr=yes;"";"
'注意: "hdr=yes"表示在第一行中是行标题,在provider中将不把第一行包括入recordset中
xlsRs.Open "Select * from [" & Replace(cboSheetName.Text, "'", "") & "]", xlsCn, adOpenKeyset, adLockOptimistic
If Err.Number <> 0 Then
MsgBox "打不开" & Text1.Text & "文件中的工作表" & cboSheetName.Text, vbCritical, "错误"
GoTo ExitCode
End If
'MsgBox "共有记录" & xlsRs.RecordCount & "需要导入", vbInformation, "提示信息"
If xlsRs.RecordCount = 0 Then
MsgBox "该工作表为空,您不必导入空表.", vbInformation, "提示信息"
'GoTo ExitCode
End If
listSource.Clear
For i = 0 To xlsRs.Fields.Count - 1
listSource.AddItem xlsRs.Fields(i).name
listSource.ItemData(i) = -1
listSource.Selected(i) = False
For j = 0 To lstDes.ListCount - 1
If lstDes.list(j) Like listSource.list(i) Then
lstDes.ItemData(j) = i
listSource.ItemData(i) = 0
listSource.Selected(i) = True
End If
Next
Next
ExitCode:
Set xlsRs = Nothing
Set xlsCn = Nothing
End SubPrivate Sub cmdLink_Click()
Dim i As Integer
For i = 0 To lstDes.ListCount - 1
If lstDes.Selected(i) And listSource.ListIndex <> -1 Then
lstDes.ItemData(i) = listSource.ListIndex
listSource.ItemData(listSource.ListIndex) = 0
lstDes.Selected(i) = True
End If
Next
End SubPrivate Sub cmdOpen_Click()
Dim i As Integer
cmdDlg.Filter = "(Excel文件)|*.xls"
cmdDlg.ShowOpen
If cmdDlg.FileName = "" Then Exit Sub
Text1.Text = cmdDlg.FileName
'取得工作表名
On Error Resume Next
Dim db As Database
Set db = OpenDatabase(Text1.Text, False, False, "Excel 8.0;")
cboSheetName.Clear
For i = 0 To db.TableDefs.Count - 1
cboSheetName.AddItem db.TableDefs(i).name
Next
cboSheetName.ListIndex = 0
db.Close
Set db = Nothing
End Sub
Private Sub cmdUnlink_Click()
Dim i As Integer
For i = 0 To lstDes.ListCount - 1
If lstDes.Selected(i) And listSource.ListIndex <> -1 Then
lstDes.ItemData(i) = -1
lstDes.Selected(i) = False
End If
Next
End SubPrivate Sub Command1_Click()
Dim getSid As Long
Dim SucCustomerCount, SucCustomerAdd As Long '记录成功的添加的客户
Dim SucCatactorCount, SucCatactorAdd As Long '记录成功的添加的联系人
Dim GetEmail, CustomerName As String
SucCustomerCount = 0
SucCustomerAdd = 0
'**********************
SucCatactorCount = 0
SucCatactorAdd = 0
' On Error Resume Next
'判断所有选中的字段是否都关联了
j = 0
For i = 0 To listSource.ListCount - 1
If listSource.ItemData(i) = -1 And listSource.Selected(i) = True Then
MsgBox "请确认您设置好了原工作表和数据库中字段的对应关系!!!", vbInformation, "提示信息"
Exit Sub
End If
j = j + 1
Next
If j = 0 Then
MsgBox "你没有选取任何字段", vbInformation, "提示信息"
Exit Sub
End If
If checknull = False Then
MsgBox "企业名称还没有对应的Excel字段", vbInformation, "提示信息"
Exit Sub
End If
If MsgBox("请确认要将文件" & Text1.Text & "导入到" & cboemployee.Text & ",客户状态是" & cboCustomerStatus.Text, vbYesNo, "提示信息") = vbNo Then Exit Sub
If MsgBox("请确认要将文件" & Text1.Text & "导入到" & cboemployee.Text & ",客户状态是" & cboCustomerStatus.Text, vbYesNo, "请您再次确认") = vbNo Then Exit Sub
Screen.MousePointer = 13
Me.Enabled = False
'开始导入数据
Dim xlsCn As New ADODB.Connection 'ExCel连接
Dim xlsRs As New Recordset
Dim rs As New Recordset
xlsCn.CursorLocation = adUseClient
xlsCn.Open "provider=microsoft.jet.oledb.4.0;" & _
"data source=" & Text1.Text & ";" & _
"extended properties=""excel 8.0;hdr=yes;"";"
'注意: "hdr=yes"表示在第一行中是行标题,在provider中将不把第一行包括入recordset中
xlsRs.Open "Select * from [" & Replace(cboSheetName.Text, "'", "") & "]", xlsCn, adOpenKeyset, adLockOptimistic
MsgBox "共有" & xlsRs.RecordCount & "条记录需要写入"
'数据库连接,
Set Conn = New ADODB.Connection
Conn.CursorLocation = adUseClient
Conn.Open ConnStr
While Not xlsRs.EOF
DoEvents
DoEvents
StatusBar1.SimpleText = "第" & xlsRs.AbsolutePosition & "条纪录/总共" & xlsRs.RecordCount
Set rs = New Recordset
'************************************************************************************
Err.Clear
'写入客户的信息开始,如果企业名称不为空才写入
CustomerName = ""
If xlsRs(GetExcel("CustomerName")) <> "" Or Not IsNull(xlsRs(GetExcel("CustomerName"))) Then
CustomerName = xlsRs(GetExcel("CustomerName")) '客户名称不为空
Else
If GetExcel("Email") <> "" Then
CustomerName = CustomerName & xlsRs(GetExcel("Email"))
End If
If GetExcel("FirstName") <> "" And GetExcel("LastName") <> "" Then
CustomerName = CustomerName & xlsRs(GetExcel("FirstName")) & xlsRs(GetExcel("LastName"))
End If
End If
If CustomerName <> "" Then
rs.Open "select * from OF_Customer where CustomerName='" & CustomerName & "'", Conn, adOpenKeyset, adLockOptimistic
If rs.EOF Then
rs.AddNew
SucCustomerAdd = SucCustomerAdd + 1
End If
For i = 0 To rs.Fields.Count - 1
'取得该字段的值
For j = 0 To lstDes.ListCount - 1
If Field2En(Trim(lstDes.list(j))) = rs(i).name And rs(i).DefinedSize <> 4 And lstDes.ItemData(j) > -1 Then
rs(i) = Trim(xlsRs(listSource.list(lstDes.ItemData(j))))
End If
Next
Next
rs("CustomerName") = CustomerName
rs("CustomerStatus") = cboCustomerStatus.Text
rs.Update
getSid = rs("CustomerID")
GetEmail = Trim(CNull(rs("Email")))
'MsgBox getSid
rs.Close
If Err.Number = 0 Then SucCustomerCount = SucCustomerCount + 1
'写入客户信息结束
'************************************************************************************
'写入联系人信息
Err.Clear
rs.Open "select * from OF_Contactor where CustomerId=" & getSid & "and Email='" & GetEmail & "'", Conn, adOpenStatic, adLockOptimistic
If rs.EOF Then
rs.AddNew
rs("Email") = GetEmail
rs("CustomerId") = getSid
SucCatactorAdd = SucCatactorAdd + 1
End If
For i = 0 To rs.Fields.Count - 1
'取得该字段的值
For j = 0 To lstDes.ListCount - 1
If Field2En(lstDes.list(j)) = rs(i).name And (rs(i).DefinedSize <> 4 Or LCase(rs.Fields(i).name) = LCase("EmployeeId")) And lstDes.ItemData(j) > -1 Then
rs(i) = Trim(Left(xlsRs(listSource.list(lstDes.ItemData(j))), rs(i).DefinedSize))
End If
Next
Next
'默认将联系人分配给职员
If cboemployee.ItemData(cboemployee.ListIndex) <> 0 Then
rs("EmployeeId") = cboemployee.ItemData(cboemployee.ListIndex)
End If
rs("Email") = GetEmail
rs.Update
' MsgBox getSid
rs.Close
'************************************************************************************
If Err.Number = 0 Then SucCatactorCount = SucCatactorCount + 1
End If
xlsRs.MoveNext
Wend
Set rs = Nothing
Set Conn = Nothing
Set xlsRs = Nothing
Set xlsCn = Nothing
MsgBox "导入成功!!", vbInformation, "提示信息"
MsgBox "成功的加入" & SucCustomerAdd & "个客户资料和" & SucCatactorAdd & "个联系人资料" & vbCrLf & ",修改了" & _
"修改了" & SucCustomerCount - SucCustomerAdd & "个客户资料和" & SucCatactorCount - SucCatactorAdd & "个联系人资料"
StatusBar1.SimpleText = "完成了任务!!"
Screen.MousePointer = vbDefault
Me.Enabled = True
End Sub