VBA 数组重新排列数据

hchsir

这是我自己编辑的代码，总是提示 边界溢出，请教老师，我的代码错在哪里了？能否指正？感谢

Public Sub SX()
Dim i, j, arr, brr, n
arr = [a1].CurrentRegion
ReDim brr(1 To 50, 1 To 50)
For j = 1 To 32
For i = 1 To UBound(arr)
If arr(i, 1) = Range("e" & j).Value Then
n = n + 1
brr(j, n) = arr(i, 2)
End If
Next
Next
Range("f1").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

cjc209

我给你写的 你看看

hchsir

cjc209 发表于 2020-10-18 22:03
我给你写的 你看看

请教下，我写的那个代码哪里出现了错误？

cjc209

hchsir 发表于 2020-10-18 22:07
请教下，我写的那个代码哪里出现了错误？

你的n循环没有归零 应该在j循环开始的时候写上n = 0

cjc209

你这种如果要全部提取ABCD的话就用字典法 指定提取可以这样用

hchsir

cjc209 发表于 2020-10-18 22:18
你的n循环没有归零 应该在j循环开始的时候写上n = 0

感谢 ，感谢，加上0后，果然正确运行了。

cjc209

你的可以改成
Public Sub SX()
    Dim i, j, arr, brr, n
    arr = [a1].CurrentRegion
    ReDim brr(1 To 50, 1 To 50)
    For j = 1 To 32
    n = 0
        For i = 1 To UBound(arr)
            If arr(i, 1) = Range("e" & j).Value Then
                n = n + 1
                brr(j, n) = arr(i, 2)
            End If
        Next
        If Range("e" & j) = "" Then Exit For
    Next
    Range("f1").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

1016373263

Sub 重排数据()
    Dim d As Object, arr, ar()
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a1").CurrentRegion
        For i = 1 To UBound(arr)
            If Not d.exists(arr(i, 1)) Then
                d(arr(i, 1)) = Array(arr(i, 2))
            Else
                ar = d(arr(i, 1))
                ReDim Preserve ar(0 To UBound(ar) + 1)
                ar(UBound(ar)) = arr(i, 2)
                d(arr(i, 1)) = ar
            End If
        Next
    [e1].Resize(d.Count, 1) = Application.Transpose(d.keys)
        For i = 0 To d.Count - 1
            Cells(i + 1, 6).Resize(1, UBound(d.items()(i)) + 1) = d.items()(i)
        Next
End Sub

1016373263

字典重排数据