|
发表于 2017-8-5 16:44
来自手机
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 jiaxinl 于 2017-8-5 17:00 编辑
用VBA做了,见附件代码如下:
Sub 转换1()
Dim d As Object, arr, i&, m&
Set d = CreateObject("scripting.dictionary")
With Sheet1
arr = .Range("A2:D" & .Range("A" & Rows.Count).End(xlUp).Row)
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
m = m + 1
d(arr(i, 1)) = m
arr(m, 1) = arr(i, 1)
arr(m, 2) = arr(i, 3) & arr(i, 4)
Else
If InStr(arr(d(arr(i, 1)), 4), arr(i, 4)) = 0 Then
arr(d(arr(i, 1)), 2) = arr(d(arr(i, 1)), 2) & "、" & arr(i, 3) & arr(i, 4)
End If
End If
Next
.Range("F1").CurrentRegion.ClearContents
.[F1] = .[A1]: .[G1] = .[D1]
.Range("F2").Resize(m, 2) = arr
End With
End Sub
Sub 转换2()
Dim d As Object, arr, i&, m&, j&
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
With Sheet1
arr = .Range("A2:D" & .Range("A" & Rows.Count).End(xlUp).Row)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
m = m + 1
d(arr(i, 1)) = m
arr(m, 1) = arr(i, 1)
arr(m, 2) = arr(i, 3) & "," & arr(i, 4)
Else
If InStr(arr(d(arr(i, 1)), 4), arr(i, 4)) = 0 Then
a = arr(d(arr(i, 1)), 2)
arr(d(arr(i, 1)), 2) = arr(d(arr(i, 1)), 2) & "," & arr(i, 3) & "," & arr(i, 4)
End If
End If
Next
.Range("I1").CurrentRegion.ClearContents
.Range("I2").Resize(m, 2) = Application.Rept(arr, 1)
Application.DisplayAlerts = False '禁止提示
'以下是分列
.Range("J2:J" & .Cells(Rows.Count, 10).End(3).Row).Select
Selection.TextToColumns Destination:=Range("J2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True '允许提示
'填表头
.[I1] = .[A1]
For j = 1 To (.Range("I1").CurrentRegion.Column - 1) / 2
.Cells(1, .Cells(1, Columns.Count).End(1).Column + 1) = .[C1]
.Cells(1, .Cells(1, Columns.Count).End(1).Column + 1) = .[D1]
Next j
.[I1].Select
Application.ScreenUpdating = True
End With
End Sub
|
|