[已解决]如何写代码,实现 自动填充,重复的去重复(新的附件和例子在30楼层)

studystudy

附件下载新的附件和例子在30楼层)

````````````````````````````````````

问题是这样的...

1对应
01 02
01 03
01 04
01 05
01 06



2对应
01 06
01 07
01 08
01 09
01 10



3对应
01 10
01 11
02 03
02 04
02 05


4对应
02 05
02 06
02 07
02 08
02 09




若 A1=1,那么B列就出现1对应的

01 02
01 03
01 04
01 05
01 06



若A1=12,那么B列就出现1,2对应的数据



01 02
01 03
01 04
01 05
01 06
(01 06)------这组数据1和2都有,去重复保留一组即可
01 07
01 08
01 09
01 10



若A1=134,那么B列就出现1,3,4对应的数据

01 02
01 03
01 04
01 05
01 06
01 10
01 11
02 03
02 04
02 05
(02 05)-----------这组数据3和4都有,去重复保留一组即可
02 06
02 07
02 08
02 09


各位老师 如何写代码...才能实现这样的功能?
```````````````````````````````
补充说明--
前面举的例子....


1对应
01 02
01 03
01 04
01 05
01 06
对应的意思是....当我在A1输入1时,,B列就出现以下 数据--------
01 02
01 03
01 04
01 05
01 06


2对应
01 06
01 07
01 08
01 09
01 10
对应的意思是....当我在A1输入2时,,B列就出现以下 数据--------
01 06
01 07
01 08
01 09
01 10
`````````````````````````````
可以说是 互相转换 的意思...

当我在A1输入12时.....
程序就把1对应的数据和2对应的数据都输出到B列.并对B列的数据进行去重复排序....


不知道这样说 ,能看明白了吗?
`

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-28 11:16

1. Sub Macro1()
   
2. Dim arr, d, d2, i&, j&, x, y, w
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. [b:b].ClearContents
   
6. arr = Range("g1").CurrentRegion
   
7. For j = 1 To UBound(arr, 2)
   
8.     For i = 2 To UBound(arr)
   
9.         x = Replace(arr(1, j), "对应", "")
   
10.         If arr(i, j) <> "" Then d(x) = d(x) & "," & arr(i, j)
    
11.     Next
    
12. Next
    
13. w = Split([a1])
    
14. For i = 0 To UBound(w)
    
15.     y = Split(d(w(i)), ",")
    
16.     For j = 1 To UBound(y)
    
17.         d2(y(j)) = ""
    
18.     Next
    
19. Next
    
20. Range("b1").Resize(d2.Count) = Application.Transpose(d2.keys)
    
21. End Sub
    

复制代码

跳转到最佳答案楼层

studystudy

爱疯

对应规则已列举了1到4，该规则最小和最大的数是什么。

studystudy

爱疯 发表于 2014-2-27 08:15
对应规则已列举了1到4，该规则最小和最大的数是什么。

老师好

15个 这样....

爱疯

Dim A(1 To 75, 1 To 1)
'***************************************************************************
'生成数据源
Sub test1()
    Dim x, y, i

    x = 1: y = 1
    For i = 1 To UBound(A)
        '存入
        y = y + 1
        A(i, 1) = Format(x, "00") & " " & Format(y, "00")

        '判断
        If i Mod 5 = 0 Then y = y - 1    '必须先确定y，后确定x
        If y = 11 Then x = x + 1: y = x
    Next i
    '    [f1].Resize(UBound(A)) = A
End Sub
'***************************************************************************
'提取结果
Sub test2()
    Dim i, j, x, y, z, B, d

    x = [a1]
    Call test1
    ReDim B(1 To UBound(A), 1 To 1)

    '在数据源中找出对应的值
    For i = 1 To Len(x)
        y = Mid(x, i, 1)
        y = (y - 1) * 5 + 1 '转为A中的起点
        For j = y To y + 4
            z = z + 1
            B(z, 1) = A(j, 1)
        Next j
    Next i

    '去重复
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To z
        d(B(i, 1)) = ""
    Next i
   
    '输出
    Range("b:b").ClearContents
    [b1].Resize(d.Count) = Application.Transpose(d.keys)
End Sub
26-2.rar (10.52 KB, 下载次数: 7)

2014-2-27 10:19 上传

点击文件名下载附件


启用test1最后一句，输出的是全部对应值吗？
禁用test1最后一句，输出的是希望的效果吗？

studystudy

老师好...要是我想 改 1-15 这些 所包含的数据...
怎么修改???

studystudy

1-15对应的数组..是 固定的.
但没什么规则.
所以

想要的结果是.....1-15个 对应的 数组.可以自定义修改....

代码能实现 从中 抽取,重复的去重复,写入B列就好

爱疯

启用test1最后一句，f列输出的是全部对应值吗？

studystudy

啊  不懂用...改成 执行  test1,,,没反应

爱疯

1楼里，你列举了
1对应的结果
2对应的结果
3对应的结果
4对应的结果
...
是不是最多到15对的结果？