[已解决]如何用VBA将相部分列内容相同的行合并成一行

zhaoguang0920 · 发表于 2015-5-25 10:27

规则 "1.若项目编号及内容1，内容2，内容3全部完全相同，将内容5,6,7放在一行.此时如果内容4相同，则取其中任意一个；若不同，则将内容合并。
2.若内容1,2,3中有任意一个不同，则分为多行"
原内容

项目编号内容1 内容2 内容3 内容4 内容5 内容6 内容7
A 你好我是1 断裂牛 3.5 - -
A 你好我是1 断裂牛 - 7.5 -
B 橘子橙子苹果猪 2 4 -
A 你好我是1 断裂牛 - - 10
C 收音机洗衣机橱柜桌子 2 - -
C 收音机洗衣机电脑椅子 - 4 -
B 橘子橙子苹果羊 - - 3

目标内容

项目编号内容1 内容2 内容3 内容4 内容5 内容6 内容7
A 你好我是1 断裂牛 3.5 7.5 10
B 橘子橙子苹果猪.羊 2 4 3
C 收音机洗衣机橱柜桌子 2 - -
C 收音机洗衣机电脑椅子 - 4 -

最佳答案

月排行榜 / 总排行榜

dsmch

2015-5-25 12:12

zhaoguang0920 发表于 2015-5-25 11:33
您好，您的这个我打开之后显示macro unavailable。您能把代码粘过来吗，谢啦

alt+f11查看代码

Sub Macro1()
Dim arr, brr, d, i&, j%, s&, n&
Set d = CreateObject("scripting.dictionary")
arr = [a5:h12]
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
zf = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4)
If Not d.exists(zf) Then
s = s + 1
d(zf) = s
For j = 1 To UBound(arr, 2)
brr(s, j) = arr(i, j)
Next
Else
n = d(zf)
If InStr(brr(n, 5), arr(i, 5)) = 0 Then brr(n, 5) = brr(n, 5) & "." & arr(i, 5)
For j = 6 To UBound(arr, 2)
If IsNumeric(arr(i, j)) Then brr(n, j) = arr(i, j)
Next
End If
Next
Range("a17").Resize(s, UBound(brr, 2)) = brr
End Sub

复制代码

跳转到最佳答案楼层

zhaoguang0920 · 发表于 2015-5-25 10:29

详情见附件

dsmch · 发表于 2015-5-25 11:11

………………

grf1973 · 发表于 2015-5-25 11:22

Sub tt()
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 100)
Set d = CreateObject("scripting.dictionary") '控制行
Set d1 = CreateObject("scripting.dictionary") '控制列
For i = 1 To UBound(arr)
x = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5)
If Not d.exists(x) Then
n = n + 1
d(x) = n
For j = 1 To 5: brr(n, j) = arr(i, j): Next
d1(x) = 5
End If
p = d(x)
For j = 6 To UBound(arr, 2)
If Len(arr(i, j)) > 0 And InStr(arr(i, j), "-") = 0 Then
d1(x) = d1(x) + 1
If d1(x) > jmax Then jmax = d1(x)
brr(p, d1(x)) = arr(i, j)
End If
Next
Next
[a13].Resize(n, jmax) = brr
[a14].Resize(n - 1, jmax).Sort key1:=[a14]
End Sub

复制代码

zhaoguang0920 · 发表于 2015-5-25 11:33

dsmch 发表于 2015-5-25 11:11
………………

您好，您的这个我打开之后显示macro unavailable。您能把代码粘过来吗，谢啦

zhaoguang0920 · 发表于 2015-5-25 11:36

grf1973 发表于 2015-5-25 11:22

您好，测试之后结果如下：
项目编号  内容1  内容2  内容3  内容4  内容5  内容6  内容7
A  你好  我是1  断裂  牛  3.5  7.5  10
B  橘子  橙子  苹果  猪  2  4 
B  橘子  橙子  苹果  羊  3
C  收音机  洗衣机  橱柜  桌子  2 
C  收音机  洗衣机  电脑  椅子  4 
B行的那个3跑到内容5里了，本来他应该是内容7的。
这肿么办呀。。

dsmch · 发表于 2015-5-25 12:12

zhaoguang0920 发表于 2015-5-25 11:33
您好，您的这个我打开之后显示macro unavailable。您能把代码粘过来吗，谢啦

alt+f11查看代码

Sub Macro1()
Dim arr, brr, d, i&, j%, s&, n&
Set d = CreateObject("scripting.dictionary")
arr = [a5:h12]
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
zf = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4)
If Not d.exists(zf) Then
s = s + 1
d(zf) = s
For j = 1 To UBound(arr, 2)
brr(s, j) = arr(i, j)
Next
Else
n = d(zf)
If InStr(brr(n, 5), arr(i, 5)) = 0 Then brr(n, 5) = brr(n, 5) & "." & arr(i, 5)
For j = 6 To UBound(arr, 2)
If IsNumeric(arr(i, j)) Then brr(n, j) = arr(i, j)
Next
End If
Next
Range("a17").Resize(s, UBound(brr, 2)) = brr
End Sub

复制代码

grf1973 · 发表于 2015-5-25 13:20

没注意要求，以为前五项为key。改过来了。

Sub tt()
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 100)
Set d = CreateObject("scripting.dictionary") '控制行
Set d1 = CreateObject("scripting.dictionary") '控制列
For i = 1 To UBound(arr)
x = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4)
If Not d.exists(x) Then
n = n + 1
d(x) = n
For j = 1 To 5: brr(n, j) = arr(i, j): Next
d1(x) = 5
End If
p = d(x)
If InStr(brr(p, 5), arr(i, 5)) = 0 Then brr(p, 5) = brr(p, 5) & "." & arr(i, 5)
For j = 6 To UBound(arr, 2)
If Len(arr(i, j)) > 0 And InStr(arr(i, j), "-") = 0 Then
d1(x) = d1(x) + 1
If d1(x) > jmax Then jmax = d1(x)
brr(p, d1(x)) = arr(i, j)
End If
Next
Next
[a13].Resize(n, jmax) = brr
[a14].Resize(n - 1, jmax).Sort key1:=[a14]
End Sub

复制代码

zhaoguang0920 · 发表于 2015-5-26 10:17

dsmch 发表于 2015-5-25 12:12
alt+f11查看代码

赶脚自己好笨啊。新手看不懂代码，前辈能稍微解释一下吗。。

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

[已解决]如何用VBA将相部分列内容相同的行合并成一行

点评