多列转一列

zhaogang1960

请测试：
Sub Macro1()
    Dim arr, brr(), d As Object, ds As Object, i&, j%, temp%, lr%
    arr = Range("N1:Y6")
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    For j = 1 To UBound(arr, 2)
        Set d(j) = CreateObject("scripting.dictionary")
    Next
    For i = 2 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If Len(arr(i, j)) Then d(j)(arr(i, j)) = "" '不计“空白”
        Next
    Next
    arr = Range("A2:L" & Range("A65536").End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For j = 1 To UBound(arr, 2)
        For i = 1 To UBound(arr)
            arr(i, j) = Format(arr(i, j), "00")
            temp = Val(Left(arr(i, j), 1)) + Val(Right(arr(i, j), 1))
            If d(j).Exists(temp) Then
                ds(j) = ds(j) + 1
                brr(ds(j), j) = arr(i, j)
            ElseIf d(j).Exists(Val(Right(temp, 1))) Then '取个位数
                ds(j) = ds(j) + 1
                brr(ds(j), j) = arr(i, j)
            End If
        Next
        If ds(j) > lr Then lr = ds(j)
    Next
    Range("N7:Y" & ActiveSheet.UsedRange.Rows.Count).ClearContents
    With Range("N7").Resize(lr, UBound(arr, 2))
        .Value = brr
        .NumberFormatLocal = "00"
    End With
End Sub

thqiou

我是看了你回复FU8989的VBA的帖，感觉我这个东西对于你来讲，应该特别简单，
也帮我看看，谢了

zhaogang1960

谢谢楼上的信任，这个课题对我来说可以说是可望不可及的，请向高手求助吧

FU8989

谢谢 可是T列和Y列二数是相减的 必须是十位减个位 如果不够减加10后再减个位 麻烦你了

zhaogang1960

请测试
333333.rar (11.56 KB, 下载次数: 7)

2009-10-20 23:29 上传

点击文件名下载附件

FU8989

还有出错 看附件

FU8989

zhaogang1960 寻求你解决这个问题 谢谢了

zhaogang1960

请测试
筛选路数字.rar (61.35 KB, 下载次数: 13)

2009-10-23 16:22 上传

点击文件名下载附件

FU8989

试好了 很好 多谢谢你

FU8989

我用起来有出错的  看附件 麻烦你修改一下
补充说明:
把0,1,2,3,4,5,6,7,8,9十个数字  分为三路   0路是369    一路是147    2路是258
要求0000----9999一万个四位数字中找出---含有3路的数字来 缺少其中1路的不要
谢谢