要从原始数据创建平面文件,请执行以下操作:
Sub GetData()
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String, t As Variant, x As Variant
Dim i As Integer, j As Integer, k As Integer
''This is not the best way to refer to the workbook
''you want, but it is very conveient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT * " _
& "FROM [Sheet1$] "
''Open the recordset for more processing
''Cursor Type: 3, adOpenStatic
''Lock Type: 3, adLockOptimistic
''Not everything can be done with every cursor type and
''lock type. See http://www.w3schools.com/ado/met_rs_open.asp
rs.Open strSQL, cn, 3, 3
''Pick a suitable empty worksheet for the results
With Worksheets("Sheet2")
''Fill headers into the first row of the worksheet
.Cells(1, 1) = "ID"
.Cells(1, 2) = "Exam"
.Cells(1, 3) = "Grade"
.Cells(1, 4) = "Points"
''Working with the recordset ...
''Counter for Fields/Columns in Recordset and worksheet
''Row one is used with titles, so ...
i = 1
Do While Not rs.EOF
''Store the ID to a string (if it is a long,
''change the type) ...
s = rs!ID
t = Split(rs!testinfo, " ")
For j = 0 To UBound(t)
''(Counter)
i = i + 1
.Cells(i, 1) = s
x = Split(t(j), "-")
For k = 0 To UBound(x)
If t(j) = "BA-1" Then
.Cells(i, 2) = "B"
.Cells(i, 3) = "A"
.Cells(i, 4) = 1
Else
.Cells(i, k + 2) = x(k)
End If
Next
Next
''Keep going
rs.MoveNext
Loop
''Finished with the sheet
End With
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
要检查额外的列:
Sub CheckData()
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String, t As Variant, x As Variant
Dim i As Integer, j As Integer, k As Integer
Dim BAErr, MErr, IErr
strFile = ActiveWorkbook.FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT * " _
& "FROM [Sheet1$] "
rs.Open strSQL, cn, 3, 3
Do While Not rs.EOF
t = Split(rs!testinfo, " ")
For j = 0 To UBound(t)
x = Split(t(j), "-")
Select Case x(0)
Case "BA"
If rs![test b] <> "BA" Then
BAErr = BAErr & "," & rs!ID
End If
Case "M"
If String(rs![test m], "I") <> x(1) Then
MErr = MErr & "," & rs!ID
End If
Case "I"
If String(rs![test i], "I") <> x(1) Then
IErr = IErr & "," & rs!ID
End If
End Select
Next
rs.MoveNext
Loop
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
If BAErr <> "" Then
MsgBox Mid(BAErr, 2), , "B Errors"
End If
If MErr <> "" Then
MsgBox Mid(MErr, 2), , "M Errors"
End If
If IErr <> "" Then
MsgBox Mid(IErr, 2), , "I Errors"
End If
End Sub
