程序代码：
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
Test.rar
(3.54 KB)
