[已解决]请高手编写代码

ymq123

请高手编写代码，说明在附件内。谢谢！

最佳答案

月排行榜 / 总排行榜

csmctjg

2013-6-1 09:21

1. Sub aa()
   
2.     Dim i%, j%, k%, str$, arr, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 2 To 6
   
5.         For j = 1 To 8
   
6.             str = str & Cells(i, j) & ","
   
7.         Next
   
8.         d(str) = ""
   
9.         str = ""
   
10.     Next
    
11.     For i = 8 To 12
    
12.         For j = 1 To 8
    
13.             str = str & Cells(i, j) & ","
    
14.         Next
    
15.         If Not d.Exists(str) Then
    
16.             k = k + 1
    
17.             Cells(k + 7, 11).Resize(1, 8) = Cells(i, 1).Resize(1, 8).Value
    
18.         Else
    
19.             d.Remove str
    
20.         End If
    
21.         str = ""
    
22.     Next
    
23.     arr = d.Keys
    
24.     For i = 0 To UBound(arr)
    
25.         Cells(i + 2, 11).Resize(1, 8) = Split(arr(i), ",")
    
26.     Next
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

csmctjg

1. Sub aa()
   
2.     Dim i%, j%, k%, str$, arr, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 2 To 6
   
5.         For j = 1 To 8
   
6.             str = str & Cells(i, j) & ","
   
7.         Next
   
8.         d(str) = ""
   
9.         str = ""
   
10.     Next
    
11.     For i = 8 To 12
    
12.         For j = 1 To 8
    
13.             str = str & Cells(i, j) & ","
    
14.         Next
    
15.         If Not d.Exists(str) Then
    
16.             k = k + 1
    
17.             Cells(k + 7, 11).Resize(1, 8) = Cells(i, 1).Resize(1, 8).Value
    
18.         Else
    
19.             d.Remove str
    
20.         End If
    
21.         str = ""
    
22.     Next
    
23.     arr = d.Keys
    
24.     For i = 0 To UBound(arr)
    
25.         Cells(i + 2, 11).Resize(1, 8) = Split(arr(i), ",")
    
26.     Next
    
27. End Sub
    

复制代码

夫子会学

这里高手不少。我是来学习的，要学到什么时候才会写代码呀。

wp8680

经过反复读题，发现表5-6的数据结果与要求1-2不符，请核实！
可以清空后试验代码运行。
请老师编写代码.rar (16.9 KB, 下载次数: 5)

2013-6-1 12:07 上传

点击文件名下载附件

1. Private Sub CommandButton1_Click()
   
2.     Dim srr(), arr, x As Integer, y As Integer, st As String
   
3.     Dim trr(), brr
   
4.     Dim urr(), vrr(), wrr(), xrr(), k As Integer
   
5.     On Error Resume Next
   
6.     arr = Application.InputBox("请选择第一区域", "提示：", , 200, 50, , , 8)
   
7.     ReDim srr(1 To UBound(arr, 1), 1 To 1)
   
8.     For x = 1 To UBound(arr, 1)
   
9.         For y = 1 To UBound(arr, 2)
   
10.             If arr(x, y) = "" Then arr(x, y) = " "
    
11.             st = st & arr(x, y)
    
12.         Next y
    
13.         srr(x, 1) = st
    
14.         st = ""
    
15.     Next x
    
16.     brr = Application.InputBox("请选择第二区域" & Chr(10) & Chr(10) & "请注意拉选时的列数须与第一区域一致！", "提示：", , 200, 100, , , 8)
    
17.     ReDim trr(1 To UBound(brr, 1), 1 To 1)
    
18.     For x = 1 To UBound(brr, 1)
    
19.         For y = 1 To UBound(brr, 2)
    
20.             If brr(x, y) = "" Then brr(x, y) = " "
    
21.             st = st & brr(x, y)
    
22.         Next y
    
23.         trr(x, 1) = st
    
24.         st = ""
    
25.     Next x
    
26.     '-----------------------------------------------
    
27.     For a = 1 To UBound(srr, 1)
    
28.         If Application.WorksheetFunction.Match(srr(a, 1), trr, 0) < 0 Then
    
29.             k = k + 1
    
30.             ReDim Preserve urr(1 To 1, 1 To k)
    
31.             urr(1, k) = srr(a, 1)
    
32.         End If
    
33.     Next a
    
34.     ReDim vrr(1 To UBound(urr, 2), 1 To UBound(arr, 2))
    
35.     For x = 1 To UBound(urr, 2)
    
36.         For y = 1 To UBound(arr, 2)
    
37.             vrr(x, y) = Mid(urr(1, x), y, 1)
    
38.         Next y
    
39.     Next x
    
40.     Range("k2").Resize(UBound(urr, 2), UBound(arr, 2)) = vrr
    
41.    
    
42. '-----------------------------------------------
    
43.   k = 0
    
44.    For a = 1 To UBound(trr, 1)
    
45.         If Application.WorksheetFunction.Match(trr(a, 1), srr, 0) < 0 Then
    
46.             k = k + 1
    
47.             ReDim Preserve wrr(1 To 1, 1 To k)
    
48.             wrr(1, k) = trr(a, 1)
    
49.         End If
    
50.     Next a
    
51.     ReDim xrr(1 To UBound(wrr, 2), 1 To UBound(arr, 2))
    
52.     For x = 1 To UBound(wrr, 2)
    
53.         For y = 1 To UBound(arr, 2)
    
54.             xrr(x, y) = Mid(wrr(1, x), y, 1)
    
55.         Next y
    
56.     Next x
    
57.    Range("k8").Resize(UBound(wrr, 2), UBound(arr, 2)) = xrr
    
58. 
    
59. End Sub

复制代码

ymq123

csmctjg 发表于 2013-6-1 09:21

老师你好：我把附件发给你，表3中数据是文本格式，请改为数值格式。谢谢！

ymq123

csmctjg 发表于 2013-6-1 09:21

老师你好：我把附件发给你，表3中数据是文本格式，请改为数值格式。谢谢！

ymq123

csmctjg 发表于 2013-6-1 09:21

老师你好：请把表3中的数字由文本形式改为数值形式。谢谢