|
直接帮你写了一个,看看能不能用啊?
假设你所有的文本都是一样的格式
试题模板(原始下载) - 初级实务-test.zip
(61.63 KB, 下载次数: 2)
Dim currentRange As Range
Private Sub CommandButton1_Click()
splitString currentRange, True
End Sub
Private Sub CommandButton2_Click() '批量分割
Dim iRow As Integer
If MsgBox("不包含以下字符的行将被忽略 :" & Chr(10) & "(本题" & Chr(10) & "分)" & Chr(10) & "A." & Chr(10) & "您要继续吗 ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
For iRow = 3 To 30000
If Range("b" & iRow) = "" Then Exit For
splitString Range("b" & iRow)
Next
MsgBox "Done"
End Sub
Private Sub Worksheet_SelectonChange(ByVal Target As Range)
On Error GoTo errexit:
If Target.Count > 1 Then Exit Sub
If Target.Column = 2 And Target.Row >= 3 Then
CommandButton1.Top = Target.Top
Set currentRange = Target
End If
Exit Sub
errexit:
End Sub
Sub splitString(xRange As Range, Optional showMsg As Boolean = False)
If xRange Is Nothing Then Exit Sub
On Error Resume Next
Dim i1 As Integer, i2 As Integer, i3 As Integer '查找 (本题 分) A.的位置
Dim part1String As String, part2string As String
Dim arrString
i1 = InStr(xRange.Value, "(本题")
i2 = InStr(xRange.Value, "分)")
i3 = InStr(xRange.Value, "A.")
If i1 = 0 Or i2 = 0 Or i3 = 0 Then
If showMsg = True Then MsgBox "必须包含 :" & Chr(10) & "(本题" & Chr(10) & "分)" & Chr(10) & "A." & Chr(10) & "这这些字符", vbCritical
Exit Sub
End If
part1String = Mid(xRange.Value, i2 + 3, i2)
part2string = Mid(xRange.Value, i3, 5000)
arrString = Split(part2string, Chr(10)) '剩下的选项部分,按照chr(10)分割成数组
Dim iLoop As Integer
'填写分数
If i1 > 0 Then Cells(xRange.Row, 6) = Mid(xRange.Value, i1 + 3, i2 - i1 - 3)
'填写题干
Cells(xRange.Row, 2) = part1String
'剩下的进行循环
For iLoop = 0 To UBound(arrString)
Cells(xRange.Row, iLoop + 7) = Mid(arrString(iLoop), 3, 1000)
Next
End Sub
|
|