多列转一列

zhaogang1960

请测试：
Sub Macro1()
    Dim a, arr, brr(1 To 16), d As Object, k, t
    Dim i&, j%, m%, l%, n%
    arr = Range("G1:g" & Range("g65536").End(xlUp).Row)
    For i = Range("g65536").End(xlUp).Row To 1 Step -1
        If arr(i, 1) <> "" Then Exit For
    Next
    arr = Range("G1:O" & i)
    Set d = CreateObject("scripting.dictionary")
    With WorksheetFunction
        For l = 1 To UBound(arr, 2)
            If l <> 5 Then
                If l < 5 Then n = 9 Else n = 2
                m = m + 2
                For j = 0 To n
                    For i = UBound(arr) To 1 Step -1
                        If Val(arr(i, l)) = j Then Exit For
                        d(j) = d(j) + 1
                    Next
                Next
                k = d.Keys
                t = d.Items
                brr(m) = .Max(t)
                brr(m - 1) = k(.Match(brr(m), t, 0) - 1)
                d.RemoveAll
            End If
        Next
    End With
    Range("Q25").Resize(1, 16) = brr
End Sub

FU8989

非常谢谢你 试好了  如果要在X列和Y列中间插入2空白列怎样修改宏  谢谢

zhaogang1960

请测试：
Sub Macro1()
    Dim arr, brr(1 To 18), d As Object, k, t
    Dim i&, j%, l%, n%
    arr = Range("G1:g" & Range("g65536").End(xlUp).Row)
    For i = Range("g65536").End(xlUp).Row To 1 Step -1
        If arr(i, 1) <> "" Then Exit For
    Next
    arr = Range("G1:O" & i)
    Set d = CreateObject("scripting.dictionary")
    With WorksheetFunction
        For l = 1 To UBound(arr, 2)
            If l <> 5 Then
                If l < 5 Then n = 9 Else n = 2
                For j = 0 To n
                    For i = UBound(arr) To 1 Step -1
                        If Val(arr(i, l)) = j Then Exit For
                        d(j) = d(j) + 1
                    Next
                Next
                k = d.Keys
                t = d.Items
                brr(l * 2) = .Max(t)
                brr(l * 2 - 1) = k(.Match(brr(l * 2), t, 0) - 1)
                d.RemoveAll
            End If
        Next
    End With
    Range("Q25").Resize(1, 18) = brr
End Sub

FU8989

zhaogang1960  非常感谢你的耐心帮助 试了很好 谢谢你了

FU8989

zhaogang1960 你好 又有求助你了 看附件说明 谢谢你

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)
            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)
            End If
        Next
        If ds(j) > lr Then lr = ds(j)
    Next
    ActiveSheet.UsedRange.Offset(6, 13).Clear
    With Range("N7").Resize(lr, UBound(arr, 2))
        .Value = brr
        .NumberFormatLocal = "00"
    End With
End Sub

FU8989

有出错 麻烦你测试一下 谢谢

FU8989

A列一共有0-99一百个二位数字 把A列单元格里二数相加 符合N2,N3,N4,N5,N6单元格值的筛选出来  注N2,N3,N4,N5,N6为空格不算0  麻烦你了

zhaogang1960

没有理解，请上传附件示意

FU8989

看看附件 谢谢