Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2111|回复: 4

[已解决]vba条件小改动

[复制链接]
发表于 2012-11-28 08:56 | 显示全部楼层 |阅读模式
Book13.rar (14.06 KB, 下载次数: 15)
发表于 2012-11-28 10:07 | 显示全部楼层    本楼为最佳答案   
Book13.rar (13.42 KB, 下载次数: 10)
回复

使用道具 举报

 楼主| 发表于 2012-11-28 12:21 | 显示全部楼层
zjdh 发表于 2012-11-28 10:07

zjdh老师,结果有误,我是算2:7行,10:15行,18:23行,而你是把2:8行,10:16行,18:24行的数据算进去了.
回复

使用道具 举报

发表于 2012-11-28 12:57 | 显示全部楼层
Sub test()
    Dim d1, d2, d3, rng
    Dim Arr, brr(1 To 3), key1, key2, key3
    Dim i%, j%, k%, l%, r%, str1$, str2$
    Range("d30:f9999").ClearContents
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    str1 = "0123456789"
    Set rng = Range("d2:f7")
    Arr = rng
    r = 29
    For i = 1 To 3    '3个数据源:D2:F7,D10:F15,D18:F23
        For j = 1 To 3    '因为输出区有3列
            '--------------------------------------
            For k = 1 To UBound(Arr)
                d1(Left(Arr(k, j), 1)) = ""
                d2(Mid(Arr(k, j), 2, 1)) = ""
                d3(Right(Arr(k, j), 1)) = ""
            Next
            key1 = d1.Keys: key2 = d2.Keys: key3 = d3.Keys
            brr(1) = key1: brr(2) = key2: brr(3) = key3
            '--------------------------------------
            For k = 1 To 3    '因为输出区有3行
                str2 = str1
                For l = 0 To UBound(brr(k))
                    str2 = Replace(str2, brr(k)(l), "")
                Next
                Cells(r + k, j + 3) = str2
            Next k
            '--------------------------------------
            d1.RemoveAll: d2.RemoveAll: d3.RemoveAll
        Next j
        Set rng = rng.Offset(8)
        Arr = rng
        r = r + 4
    Next i
End Sub

这样可以吗
回复

使用道具 举报

发表于 2012-11-28 14:15 | 显示全部楼层
lkjpoi 发表于 2012-11-28 12:21
zjdh老师,结果有误,我是算2:7行,10:15行,18:23行,而你是把2:8行,10:16行,18:24行的数据算进去了.

修改一个参数
Sub test()
Dim Arr, i&, x$, j&, aa$
Dim d, k, t, d1, d2
On Error Resume Next
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
aa = "0123456789"
Range("D30:F65536").ClearContents
For L = 2 To 18 Step 8
Arr = Range("D" & L & ":F" & L + 5)
W = W + 4
For j = 1 To 3
    For i = 1 To UBound(Arr)
        x = Left(Arr(i, j), 1)
        d(x) = ""
        x = Mid(Arr(i, j), 2, 1)
        d1(x) = ""
        x = Right(Arr(i, j), 1)
        d2(x) = ""
    Next
    k = d.Keys: k1 = d1.Keys: k2 = d2.Keys
    bb = aa
    For y = 0 To UBound(k)
        bb = Replace(bb, k(y), "")
    Next
    Cells(W + 26, j + 3) = bb
    bb = aa
    For y = 0 To UBound(k1)
        bb = Replace(bb, k1(y), "")
    Next
    Cells(W + 27, j + 3) = bb
    bb = aa
    For y = 0 To UBound(k2)
        bb = Replace(bb, k2(y), "")
    Next
    Cells(W + 28, j + 3) = bb
    d.RemoveAll: d1.RemoveAll: d2.RemoveAll
Next
Next
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 15:30 , Processed in 0.579188 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表