如何将EXCEL中题库转换成需要的格式显示

lion3583 · 发表于 2020-11-16 10:46

如附件所示，怎么用vb将EXCEL中左边的格式转换成右边的格式。求高手解决

zhsiyu9600 · 发表于 2020-11-16 11:00

请上附件，谢谢

lion3583 · 发表于 2020-11-16 11:05

附件，谢谢

imleading · 发表于 2020-11-16 11:31

如果全是选择题，应该比较容易。题号后面都有一个.或者abc后面都是.那还比较容易判断，判断符合就写入就好了。

准提部林 · 发表于 2020-11-16 13:05

Sub TEST_A1()
Dim Arr, Brr(1 To 20000, 1 To 8), T$, i&, k%, R&, C%
Sheet2.UsedRange.Offset(1, 0).EntireRow.Delete
Arr = Range(Sheet1.[a1], Sheet1.Cells(Rows.Count, 1).End(3))
For i = 1 To UBound(Arr)
T = Arr(i, 1)
If Val(T) > 0 Then
   k = InStrRev(T, "("): R = R + 1: C = 1
   Brr(R, 1) = Left(T, k - 1)
   Brr(R, 8) = Replace(Mid(T, k + 1), ")", "")
Else
   C = C + 1: Brr(R, C) = T
End If
i01: Next i
Sheet2.[A2].Resize(R, 8) = Brr
End Sub

Xl0000093.rar (10.44 KB, 下载次数: 5)

zpy2 · 发表于 2020-11-16 13:33

lion3583 发表于 2020-11-16 11:05
附件，谢谢

附件解析结果。。

解析结果.xlsx.zip (5.94 KB, 下载次数: 2)

machunze · 发表于 2020-11-16 14:23

粘帖运行了事，也不上传附件了

Sub 题库格式整理()
With Sheets("单选题")
.Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("A1").FormulaR1C1 = "单选题"
.Range("C1").FormulaR1C1 = "题目"
.Range("D1").FormulaR1C1 = "A"
.Range("E1").FormulaR1C1 = "B"
.Range("F1").FormulaR1C1 = "C"
.Range("G1").FormulaR1C1 = "D"
.Range("H1").FormulaR1C1 = "E"
.Range("I1").FormulaR1C1 = "答案"
Dim n As Integer, r As Integer, arr(), str As String
.Range("C2:I" & .[i65536].End(xlUp).Row + 1).ClearContents
For n = 2 To .[a65536].End(xlUp).Row
If Left(.Cells(n, "A").Text, 1) Like "#" Then
r = 0
Do
ReDim Preserve arr(0 To r)
arr(r) = .Cells(n + r, "A").Value
r = r + 1
Loop Until Left(.Cells(n + r, "A").Text, 1) Like "#" Or .Cells(n + r, "A") = ""
str = Left(Right(arr(0), 2), 1)
arr(0) = Replace(arr(0), Right(arr(0), 3), "")
.Cells(.[c65536].End(xlUp).Row + 1, "C").Resize(1, UBound(arr) + 1) = arr
.Cells(.[i65536].End(xlUp).Row + 1, "I").Value = str
End If
Next
End With
End Sub

复制代码

chxw68 · 发表于 2020-11-16 20:12

Sub test()
Dim r%, i%
Dim arr, brr
With Worksheets("单选题")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:a" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 10)
m = 0
For i = 1 To UBound(arr)
If Left(arr(i, 1), 1) Like "#" Then
m = m + 1
n = 1
brr(m, 1) = arr(i, 1)
Else
n = n + 1
brr(m, n) = Split(arr(i, 1), ".")(1)
End If
Next
With Worksheets("sheet1")
.Range("a2").Resize(m, UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2020-11-16 20:13

简单问题。

		自动登录	找回密码
密码			免费注册

[求助] 如何将EXCEL中题库转换成需要的格式显示

评分

评分

评分

评分