[已解决]VBA求改动下显示结果的位置

GYUHJ

Sub YYY8()
    Set d = CreateObject("scripting.dictionary")
    For Each RN In Range("A136:L500")
        If Not d.Exists(RN.Value) Then
            d.Add RN.Value, 1
        Else
            d(RN.Value) = d(RN.Value) + 1
        End If
    Next
    k = d.Keys
    s = d.Items
    ReDim arr(1 To UBound(s) + 1)
    For i = 0 To UBound(s)
        If s(i) > 2 And s(i) < 11 Then
            t = t + 1
            arr(t) = k(i) * 1
        End If        
    Next
    ReDim m(1 To t)
    For i = 1 To t
        m(i) = Format(Application.Small(arr, i), "000")
    Next i
    Range("AA136:AA2000").ClearContents
    Range("AA136").Resize(t, 1) = Application.Transpose(m)
    Range("AA136").NumberFormatLocal = "@"
End Sub
                  想把固定放在AA列的结果改成从AA136到BB哪列没有数据就放哪列里,

最佳答案

月排行榜 / 总排行榜

mxg825

2012-5-5 15:55

我调试正常呀。。。。。。。。。。

Sub YYY8()
    Set d = CreateObject("scripting.dictionary")
    For Each RN In Range("A136:L500")
        If Not d.Exists(RN.Value) Then
            d.Add RN.Value, 1
        Else
            d(RN.Value) = d(RN.Value) + 1
        End If
    Next
    k = d.Keys
    s = d.Items
    ReDim arr(1 To UBound(s) + 1)
    For i = 0 To UBound(s)
        If s(i) > 2 And s(i) < 11 Then
            t = t + 1
            arr(t) = k(i) * 1
        End If
    Next
    ReDim m(1 To t)
    For i = 1 To t
        m(i) = Format(Application.Small(arr, i), "000")
    Next i
'********以下是修改填写部分代码********
Dim C%
For C = 27 To 54 'AA-BB列
If Application.CountA(Cells(136, C).Resize(t, 1)) = 0 Then
With Cells(136, C)
    .Resize(t, 1) = Application.Transpose(m)
    .Resize(t, 1) .NumberFormatLocal = "@"
    End With
Exit Sub
End If
Next
MsgBox "没地方可放"
End Sub

跳转到最佳答案楼层

mxg825

Sub YYY8()
    Set d = CreateObject("scripting.dictionary")
    For Each RN In Range("A136:L500")
        If Not d.Exists(RN.Value) Then
            d.Add RN.Value, 1
        Else
            d(RN.Value) = d(RN.Value) + 1
        End If
    Next
    k = d.Keys
    s = d.Items
    ReDim arr(1 To UBound(s) + 1)
    For i = 0 To UBound(s)
        If s(i) > 2 And s(i) < 11 Then
            t = t + 1
            arr(t) = k(i) * 1
        End If
    Next
    ReDim m(1 To t)
    For i = 1 To t
        m(i) = Format(Application.Small(arr, i), "000")
    Next i
    Dim C%
    C = UsedRange.Columns.Count '有内容区域最大【列】号
    With Cells(136, C)
    .Resize(t, 1) = Application.Transpose(m)
    .NumberFormatLocal = "@"
    End With
End Sub

无聊的疯子

要是都没有呢??都放啊

Range("AA136:AA2000").ClearContents


这里已经清除了,所以这个地方是具有优先权的,如果只放一列的话,这里是首选的


{:101:}

GYUHJ

mxg825 发表于 2012-5-5 14:48
Sub YYY8()
    Set d = CreateObject("scripting.dictionary")
    For Each RN In Range("A136:L500")
...

运行错误424,我的意思是如果AA136列无数据就放AA136列,有就向后面一列放

mxg825

请看7楼。。。。，，，，，

GYUHJ

mxg825 发表于 2012-5-5 15:22
Sub YYY8()
    Set d = CreateObject("scripting.dictionary")
    For Each RN In Range("A136:L500")
...

可能还是有问题,当AA136无数时放AA列正确,当AA136有数时它应该放AB列,AB136还有数就放AC列(这样轮过去),不是当AA136有数就提示没地方放,AA136到BB只有几列有数,一定有空列

mxg825

我调试正常呀。。。。。。。。。。

Sub YYY8()
    Set d = CreateObject("scripting.dictionary")
    For Each RN In Range("A136:L500")
        If Not d.Exists(RN.Value) Then
            d.Add RN.Value, 1
        Else
            d(RN.Value) = d(RN.Value) + 1
        End If
    Next
    k = d.Keys
    s = d.Items
    ReDim arr(1 To UBound(s) + 1)
    For i = 0 To UBound(s)
        If s(i) > 2 And s(i) < 11 Then
            t = t + 1
            arr(t) = k(i) * 1
        End If
    Next
    ReDim m(1 To t)
    For i = 1 To t
        m(i) = Format(Application.Small(arr, i), "000")
    Next i
'********以下是修改填写部分代码********
Dim C%
For C = 27 To 54 'AA-BB列
If Application.CountA(Cells(136, C).Resize(t, 1)) = 0 Then
With Cells(136, C)
    .Resize(t, 1) = Application.Transpose(m)
    .Resize(t, 1) .NumberFormatLocal = "@"
    End With
Exit Sub
End If
Next
MsgBox "没地方可放"
End Sub

mxg825

楼主：最佳要 贴到5楼！才正确！