[已解决]请求帮忙修改代码

douya33 · 发表于 2013-9-27 11:42

本帖最后由 douya33 于 2013-9-27 13:12 编辑

附件文件运行下段代码时出现“运行时错误13，类型不匹配”错误，请求各位大侠谁能帮我改改代码啊？红色为出错部分。
补充说明一下：是有的时候会出错，并不是每次都会出错。
Sub test()
Application.ScreenUpdating = False
Dim arr, d, k, t, s, brr
Set d = CreateObject("Scripting.Dictionary")
arr = Range("a1").CurrentRegion
[g2:j999].ClearContents
For i = 2 To UBound(arr)
s = arr(i, 4) & "|" & arr(i, 5)
If d.exists(s) Then
d(s) = d(s) & " " & arr(i, 2)
Else
d(s) = arr(i, 2)
End If
Next
k = d.keys
t = d.items
[i2].Resize(d.Count) = Application.Transpose(k)
[g2].Resize(d.Count) = Application.Transpose(t)
d.RemoveAll
brr = Range("i2").CurrentRegion
For i = 2 To UBound(arr)
s = arr(i, 4) & "|" & arr(i, 5)
d(s) = d(s) + arr(i, 3)
Next
[h2].Resize(d.Count) = Application.Transpose(d.items)
Application.DisplayAlerts = False
[i2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
Application.DisplayAlerts = True
Set d = Nothing
Range("g2").CurrentRegion.Sort [i2], 1
With Range("g2").CurrentRegion
.Borders.LineStyle = xlContinuous
.WrapText = True
.Rows.AutoFit
End With
Application.ScreenUpdating = True
End Sub

自动合并.rar (36.69 KB, 下载次数: 11)

我心飞翔410 · 发表于 2013-9-27 11:48

Range("d1").Resize(d.Count) = Application.Transpose(d.Keys)
Range("e1").Resize(d.Count) = Application.Transpose(d.Items)
直接这样不行么

douya33 · 发表于 2013-9-27 12:11

不行哦，
Range("e1").Resize(d.Count) = Application.Transpose(d.Items)
这句还提示错误

danio112 · 发表于 2013-9-27 13:00

本帖最后由 danio112 于 2013-9-27 13:10 编辑

换成这个试试 [g2].Resize(d.Count) = d.items

douya33 · 发表于 2013-9-27 13:09

danio112 发表于 2013-9-27 13:00
换成这个试试 [g2].Resize(d.Count) = t

还有一点问题,B列的数据不能自动合并。如下图：
执行前：

R501 R502 R804 R805	4	01.02.01.0009A	YAGEO
R912	1	01.02.01.0009A	YAGEO

执行后：

R726

5

01.02.01.0009A

YAGEO

正确的结果应该是：

R501 R502 R804 R805 R912

5

01.02.01.0009A

YAGEO

美斯特邦威 · 发表于 2013-9-27 13:33

douya33 发表于 2013-9-27 12:11
不行哦，
Range("e1").Resize(d.Count) = Application.Transpose(d.Items)
这句还提示错误

出错原因是Application.Transpose(），括号的内容字符不能超过256个

sliang28 · 发表于 2013-9-27 13:41

加了一句就好了,不过只能保证本附件数据才可以.
其实主要原因是因为:item中字符串长度超过255个了吧!,个人认为是这样的.

d("01.02.01.0035A|YAGEO") = ""
k = d.keys
t = d.items

复制代码

douya33 · 发表于 2013-9-27 13:51

sliang28 发表于 2013-9-27 13:41
加了一句就好了,不过只能保证本附件数据才可以.
其实主要原因是因为:item中字符串长度超过255个了吧!,个人 ...

运行时错误‘1004’，未选定要分列的数据.{:041:}

美斯特邦威 · 发表于 2013-9-27 13:53

本帖最后由美斯特邦威于 2013-9-27 13:56 编辑

douya33 发表于 2013-9-27 13:51
运行时错误‘1004’，未选定要分列的数据.

Sub test()
Application.ScreenUpdating = False
Dim pp(1 To 100000, 1 To 3)
Dim arr, d, k, t, s, brr
Set d = CreateObject("Scripting.Dictionary")
arr = Range("a1").CurrentRegion
[g2:j999].ClearContents
For i = 2 To UBound(arr)
s = arr(i, 4) & "|" & arr(i, 5)
If d.exists(s) Then
pp(d(s), 1) = pp(d(s), 1) & " " & arr(i, 2)
pp(d(s), 2) = pp(d(s), 2) + arr(i, 3)
Else
d(s) = x + 1
pp(x + 1, 3) = s
pp(x + 1, 1) = arr(i, 2)
pp(x + 1, 2) = arr(i, 3)
x = x + 1
End If
Next i
Range("g2").Resize(x, 3) = pp
Application.DisplayAlerts = False
[i2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
Application.DisplayAlerts = True
Set d = Nothing
Range("g2").CurrentRegion.Sort [i2], 1
With Range("g2").CurrentRegion
.Borders.LineStyle = xlContinuous
.WrapText = True
.Rows.AutoFit
End With
Application.ScreenUpdating = True
End Sub

复制代码

前半部分给你换为数组
OK了，看看如何

danio112 · 发表于 2013-9-27 14:02

douya33 发表于 2013-9-27 13:09
还有一点问题,B列的数据不能自动合并。如下图：
执行前：
执行后：

代码其实真的没有错，我运行的时候成功了，可过了一会儿，又不行了，甚是奇怪，于是只好换一种输出方式输出了。
For j = 0 To d.Count - 1
Cells(j + 2, "i") = k(j)
Cells(j + 2, "g") = t(j)
Next j

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