[原创]取学生姓名和成绩

[个人原创，如转载请说明出处] 
昨天csdn bbs上有人发帖问取一段文本中学生姓名和成绩的问题。
看了看，确实数据没有什么规律。

'这里是设置的数据（略有改动）
xuesheng = "林川瑜 04财（2）班 川俊青74-63 全年.川倩倩 91，89" & vbCrLf & _
            "川文欢   86，81,69 川复兴68 78 卢川燕 90,92, 王川倩" & vbCrLf & _
            "72,85" & vbCrLf & _
            "英（1）班 川煜炯 88,96川凯捷 男" & vbCrLf & _
            "朱川钧 86 川宪珍   84,80, 李川翔 85 川清 82 李川友 79 川" & vbCrLf & _
            "昌 82 韩芝川云 84" & vbCrLf & _
            "王川 86 刘川玫  82 川萍 81 付川 78 川永新 85,90 戚川庆" & vbCrLf & _
            "70,80 蒋川 89" & vbCrLf & _
            "川红川 85 期中 川铮 85 张川元 84 姚川 87 王川 86,78" & vbCrLf & _
            "川力 83 王立建 79 川宇 85 龚川娟 86 王川立 78 川岩 72 牛" & vbCrLf & _
            "川慧 89 82"
Text1.Text = xuesheng

采用了以下方法：
1、替换其中的换行符和英文逗号
cj = Text1.Text
cj = Replace(cj, vbCrLf, " ")
cj = Replace(cj, ",", " ")

2、部分关键字过滤
Text2.Text =  "04财（2）班,全年,英（1）班,期中,，,-,., 男 "
If Trim(Text2.Text) <> "" Then
    Dim tihuan_array() As String
    tihuan_array = Split(Text2.Text, ",")
    For i = 0 To UBound(tihuan_array)
        cj = Replace(cj, tihuan_array(i), " ")
    Next
End If

3、'替换2个空格为1个
cj = Replace(cj, ",", "")
Do While InStr(cj, "  ")
    cj = Replace(cj, "  ", " ")
Loop

4、开始转换

Dim xmcj_array() As String
xmcj_array = Split(cj, " ")

Dim xmcj_sub As String
xmcj_sub = ""
For i = 0 To UBound(xmcj_array)
    If IsNumeric(xmcj_array(i)) Then        '如果是数字
        xmcj_sub = xmcj_sub & " " & xmcj_array(i)
        If i = UBound(xmcj_array) Then
            List1.AddItem xiuzheng(xmcj_sub)    '修正并显示数据
        End If
    Else
        If Len(xmcj_sub) > 1 Then
                List1.AddItem xiuzheng(xmcj_sub)    '修正并显示数据
                xmcj_sub = xmcj_array(i)
        Else
            xmcj_sub = xmcj_sub & xmcj_array(i)
        End If
    End If

Next

End Sub

5、修正姓名长度，使分数对齐
Private Function xiuzheng(xmcj1 As String) As String
Dim k As Integer

    Dim tmpa() As String
    tmpa = Split(xmcj1, " ")
    xiuzheng = ""
    For k = 0 To UBound(tmpa)
        If k = 0 Then
            xiuzheng = xiuzheng2(tmpa(0))
            If Len(xiuzheng) = 2 Then xiuzheng = xiuzheng & "  "        '不需要修正就删除
        Else
            xiuzheng = xiuzheng & " " & tmpa(k)
        End If
    Next

End Function

6、修正姓名连接分数的情况
Private Function xiuzheng2(ByVal xmcj2 As String) As String
Dim l As Integer
Dim xm As String, cj As String
xm = "": cj = ""
For l = 1 To Len(xmcj2)
    If Asc(Mid(xmcj2, l, 1)) < 0 Then
        xm = xm & Mid(xmcj2, l, 1)
    Else
        cj = cj & Mid(xmcj2, l, 1)
    End If
Next
If Len(cj) > 0 Then xiuzheng2 = xm & " " & cj Else xiuzheng2 = xm
End Function

 

完工，也许还有更好的方法！