|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub test_tj()
Dim arr, i As Long, j As Long, mycol As Long
Dim dic As Object, aa
With Worksheets("表1-数据源")
mycol = .Cells(1, Columns.Count).End(xlToLeft).Column
Set dic = CreateObject("scripting.dictionary")
For i = 1 To mycol
If Len(.Cells(1, i)) <> 0 Then
arr = .Cells(1, i).CurrentRegion
For k = 3 To UBound(arr)
dic(arr(k, 1)) = dic(arr(k, 1)) & ";" & arr(1, 1) & "," & IIf(InStr(arr(k, 2), "个"), Left(arr(k, 2), Len(arr(k, 2)) - 1), arr(k, 2))
Next
End If
Next
End With
With Worksheets("结果")
i = 1
.Cells.Clear
For Each aa In dic.keys
.Cells(i + 1, 1) = aa
kk = Split(dic(aa), ";")
For j = 1 To UBound(kk)
.Cells(i, j + 1) = Split(kk(j), ",")(0)
.Cells(i + 1, j + 1) = Split(kk(j), ",")(1)
Next
i = i + 2
Next
End With
End Sub |
|