[已解决]求助：归纳对换和删除所有单 ...

水木

求助：归纳对换和删除所有单元格中与关键字相同的字.zip (14.49 KB, 下载次数: 9)

2014-12-7 00:05 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-7 14:00

………………

跳转到最佳答案楼层

那么的帅

B20 关键字  是 书，为什么 选择 书史 做第一个，而不是  书目古今

水木

那么的帅 发表于 2014-12-7 00:25
B20 关键字  是 书，为什么 选择 书史 做第一个，而不是  书目古今

选择“书目古今”也可以，只要与“关键字”相同

dsmch

楼主的归纳有问题，代码写不下去了
如关键字有两个书，按什么规则求出结果？

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, k%, s%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 8)
   
6. For i = 2 To UBound(arr)
   
7.     For j = 3 To UBound(arr, 2)
   
8.         If arr(i, j) Like arr(i, 1) & "*" Then z = arr(i, 3): arr(i, 3) = arr(i, j): arr(i, j) = z: Exit For
   
9.     Next
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     s = 0
    
13.     For j = 9 To UBound(arr, 2)
    
14.         arr(i, j) = Replace(arr(i, j), arr(i, 8), "")
    
15.         zf = arr(i, j)
    
16.         For k = 1 To Len(zf)
    
17.             z = Mid(zf, k, 1)
    
18.             If Not d.exists(z) Then
    
19.                 d(z) = ""
    
20.                 s = s + 1
    
21.                 brr(i - 1, s) = z
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     If s > n Then n = s
    
26.     d.RemoveAll
    
27. Next
    
28. Range("i2").Resize(UBound(brr), n) = brr
    
29. End Sub

复制代码

水木

dsmch 发表于 2014-12-7 08:45
楼主的归纳有问题，代码写不下去了
如关键字有两个书，按什么规则求出结果？

先谢谢！是这个意思，只是I列相同的没有归纳一下。请您再写一下。

水木

dsmch 发表于 2014-12-7 08:45
楼主的归纳有问题，代码写不下去了
如关键字有两个书，按什么规则求出结果？

请将结果做到《数据（2）》表中

水木

dsmch 发表于 2014-12-7 08:45
楼主的归纳有问题，代码写不下去了
如关键字有两个书，按什么规则求出结果？

如关键字有两个书，按什么规则求出结果？如有两个书，只取一个，另一个相同的书删除。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, d2, i&, j%, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7. For i = 1 To UBound(arr)
   
8.     If Not d2.exists(arr(i, 8)) Then
   
9.         h = h + 1: d2(arr(i, 8)) = h
   
10.         For j = 1 To UBound(arr, 2)
    
11.             brr(h, j) = arr(i, j)
    
12.         Next
    
13.     Else
    
14.         n = d2(arr(i, 8))
    
15.         For k = 9 To UBound(arr, 2)
    
16.             If brr(n, k) = "" Then l = k:  Exit For
    
17.         Next
    
18.         For k2 = 9 To UBound(arr, 2)
    
19.             If arr(i, k2) <> "" Then
    
20.                 brr(n, l) = arr(i, k2)
    
21.                 l = l + 1
    
22.             End If
    
23.         Next
    
24.     End If
    
25. Next
    
26. For i = 2 To h
    
27.     js = 0
    
28.     For j = 9 To UBound(brr, 2)
    
29.         If brr(i, j) Like brr(i, 8) & "*" Then js = js + 1: z = brr(i, 9): brr(i, 9) = brr(i, j): brr(i, j) = z: Exit For
    
30.     Next
    
31.     If js = 0 Then
    
32.         For j2 = UBound(brr, 2) - 1 To 9 Step -1
    
33.             brr(i, j2 + 1) = brr(i, j2)
    
34.         Next
    
35.         brr(i, 9) = "-"
    
36.     End If
    
37. Next
    
38. ReDim crr(1 To UBound(brr) - 1, 1 To UBound(brr, 2) - 8)
    
39. For i = 2 To UBound(brr)
    
40.     s = 0
    
41.     For j = 9 To UBound(brr, 2)
    
42.         brr(i, j) = Replace(brr(i, j), brr(i, 8), "")
    
43.         zf = brr(i, j)
    
44.         For k = 1 To Len(zf)
    
45.             z = Mid(zf, k, 1)
    
46.             If Not d.exists(z) Then
    
47.                 d(z) = ""
    
48.                 s = s + 1
    
49.                 crr(i - 1, s) = z
    
50.             End If
    
51.         Next
    
52.     Next
    
53.     If s > n Then n = s
    
54.     d.RemoveAll
    
55. Next
    
56. Sheet2.Activate
    
57. Range("a10").Resize(h, UBound(brr, 2)) = brr
    
58. Range("i11").Resize(UBound(crr), n) = crr
    
59. End Sub

复制代码

dsmch

………………

水木

dsmch 发表于 2014-12-7 11:53
………………

谢谢！让您受累了，是这个意思。请您将行移动一下。在《数据（2）》的表中，代码运行后，请将数据显示在A2（标题之下）.
另运行代码后，出现1004的提示    Range("i11").Resize(UBound(crr), n) = crr