|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test()
- Dim i%, j%, n%
- Dim arr, brr
- arr = Sheets("sheet2").Range("a1:a" & Sheets("sheet2").Range("a65536").End(xlUp).Row + 1)
- ReDim brr(1 To UBound(arr) / 7, 1 To 8)
- n = 0
- For i = 1 To UBound(arr)
- If Left(arr(i, 1), 1) = "A" Then
- n = n + 1
- k = i
- brr(n, 1) = arr(i - 1, 1)
- brr(n, 2) = arr(i, 1)
- If Left(arr(i + 1, 1), 1) = "B" Then brr(n, 3) = arr(i + 1, 1)
- If Left(arr(i + 2, 1), 1) = "C" Then brr(n, 4) = arr(i + 2, 1)
- If Left(arr(i + 3, 1), 1) = "D" Then brr(n, 5) = arr(i + 3, 1)
- If Left(arr(i + 4, 1), 1) = "E" Then brr(n, 6) = arr(i + 4, 1)
- If Left(arr(i + 4, 1), 1) = "答" Then brr(n, 7) = arr(i + 4, 1)
- If Left(arr(i + 5, 1), 1) = "答" Then brr(n, 7) = arr(i + 5, 1)
- If Left(arr(i + 5, 1), 1) = "解" Then brr(n, 8) = arr(i + 5, 1): i = i + 5
- If Left(arr(i + 6, 1), 1) = "解" Then brr(n, 8) = arr(i + 6, 1): i = i + 6
- End If
- Next
- Sheets("sheet1").Range("a2").Resize(UBound(brr), 8) = brr
- End Sub
复制代码
文本内容导入到sheet2之后的代码。 |
|