ado 读取exce后修改另存l

Option Explicit

Dim objExl As Excel.Application '声明对象变量

Dim path As String

Const xlsfile = "b3.xls"                '保存为b3.xls

Private Sub Command1_Click()

Cls
Print "开始:"; Now

Const strbt = "姓名,综合,最小,最大"
Dim s() As String           '分解数据用的数组
Dim m As String             '保存着需要保存的数据

s = Split(strbt, ",")       '标题

m = Join(s, vbTab)
m = m & vbCrLf

Print "预处理完成:"; Now

Dim keystr As String, sql As String

'Dim con As New ADODB.Connection            '调试用，需要工程引用
'Dim rs As New ADODB.Recordset

Dim con As Object
Dim rs As Object

Set con = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

'keystr = "%" & "AA" & "%"

keystr = "AA"

con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source = " & path & "a.xls;Extended Properties='Excel 8.0;HDR=Yes'"
con.Open
sql = "select 姓名,综合 from [test$] where 项目 = '" & keystr & "';"
rs.Open sql, con, 3, 3

Print "以数据库方式打开表完成:"; Now

If rs.EOF Then
    '没有数据，不打开Excel ，不处理数据
    MsgBox "没有查到数据，文件未保存！", vbCritical

Else

Do While Not rs.EOF                         '使用DO循环
'For i = 0 To rs.RecordCount - 1
    m = m & rs.Fields("姓名") & vbTab       '前面二个值
    m = m & rs.Fields("综合") & vbTab
   
    If Len(rs.Fields("综合")) > 0 Then
   
        s = Split(rs.Fields("综合"), "-")       '第二值分为二段
        
        If UBound(s) > 0 Then                   '如果有二段数据
            If IsNumeric(s(0)) And IsNumeric(s(1)) Then     '两段都是数字
                If Val(s(0)) > Val(s(1)) Then               '如果大的前面
                    m = m & s(1) & vbTab                    '第一段
                    m = m & s(0) & vbCrLf                   '第二段
                Else
                    m = m & s(0) & vbTab                    '第一段
                    m = m & s(1) & vbCrLf                   '第二段
                End If
            Else
                '只有一个是数字
                If IsNumeric(s(0)) Then             '第一个是数字，放后面
                    m = m & vbTab & s(0) & vbCrLf
                ElseIf IsNumeric(s(1)) Then         '第二个是数字，也放后面
                    m = m & vbTab & s(1) & vbCrLf
                Else                                '否则全部留空
                    m = m & vbTab & vbCrLf
                End If
               
            End If
        Else
            If IsNumeric(s(0)) Then                     '如果只有一段，并且是数字，那放后面
                m = m & vbTab & s(0) & vbCrLf
            Else
                m = m & vbTab & vbCrLf                   '否则两段都放空
            End If
        End If
    Else
        m = m & vbTab & vbCrLf                   '否则两段都放空
    End If
   
    rs.MoveNext                             '下一条记录
'Next
Loop

Print "组合数据完成:"; Now

Set objExl = New Excel.Application          '创建一个新的 Exlce
DoEvents

Set objExl = New Excel.Application '初始化对象变量
objExl.SheetsInNewWorkbook = 1 '将新建的工作薄数量设为1
objExl.Workbooks.Add '增加一个工作薄
objExl.Sheets(objExl.Sheets.Count).Name = "Sheet1" '修改工作薄名称

objExl.Visible = True                       '显示Excel
DoEvents

Print "运行Excel完成:"; Now

objExl.Visible = True                           '显示
objExl.Sheets("sheet1").Select                  '选择
'objExl.Sheets("sheet1").Range("A1:D1") = s      '贴入标题

'按这种处理过的数据，放进去时，需要到剪切板上转一下
Clipboard.Clear
Clipboard.SetText m

objExl.Sheets("sheet1").Range("A1").PasteSpecial        '从第一行第一个格贴进去
'objExl.Sheets("sheet1").Range("A2").PasteSpecial        '从第二行第一个格贴进去
Clipboard.Clear                                         '清掉

Print "写入数据完成:"; Now

If Dir(path & xlsfile) <> "" Then
    Kill path & xlsfile
End If

objExl.ActiveWorkbook.SaveAs path & xlsfile
objExl.ActiveWorkbook.Close

End If


End Sub

Private Sub Form_Load()
path = App.path
If Right(path, 1) <> "\" Then
    path = path & "\"
End If



End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next

objExl.ActiveWorkbook.Saved = True
objExl.Quit

Set objExl = Nothing

End Sub