|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 转换()
Dim ar As Variant
Dim br()
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If r < 2 Then MsgBox "数据源为空!": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
ReDim br(1 To 10000, 1 To 5)
For j = 2 To UBound(ar, 2)
If ar(1, j) <> "" Then
For i = 2 To UBound(ar)
If ar(i, j) <> "" Then
rr = Split(ar(i, j), Chr(10))
For s = 0 To UBound(rr) - 2 Step 4
If Trim(rr(s)) <> "" Then
n = n + 1
br(n, 1) = ar(1, j)
br(n, 2) = rr(s)
br(n, 3) = ar(i, 1)
br(n, 4) = rr(s + 2)
br(n, 5) = rr(s + 1)
End If
Next s
End If
Next i
End If
Next j
With Sheets("结果表")
.[a1].CurrentRegion.Offset(1) = Empty
.[a2].Resize(n, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub
|
|