Application.WorksheetFunction.Transpose

只观看

Sub a()
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet2
        nr = .UsedRange.Rows.Count
        nc = 3
        arr = .[A1].Resize(nr, nc)
    End With
   
    For i = 1 To UBound(arr)
        If Not d.Exists(arr(i, 3)) Then
            d.Add arr(i, 3), arr(i, 1)
        Else
            If InStr(d(arr(i, 3)), arr(i, 1)) = 0 Then d(arr(i, 3)) = d(arr(i, 3)) & "," & arr(i, 1)
        End If
    Next i
   
    Sheet3.Range("A:E").ClearContents
    Sheet3.Range("A1").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)
   '数据太长不能Application.WorksheetFunction.Transpose(d.items)转换,有没有其他办法?

     Sheet3.Range("B1").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.items)     
End Sub

yes2boy

Option Explicit


Sub atest()
    Dim arr, brr, d, i, nr, nc
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet2
        nr = .Range("A65536").End(xlUp).Row
        nc = 3
        arr = .[A1].Resize(nr, nc)
    End With
    For i = 1 To UBound(arr)
        If Not d.Exists(arr(i, 3)) Then
            d.Add arr(i, 3), arr(i, 1)
        Else
            If InStr(d(arr(i, 3)), arr(i, 1)) = 0 Then
                d(arr(i, 3)) = d(arr(i, 3)) & "," & arr(i, 1)
            End If
        End If
    Next i
    Sheet3.Range("A:E").ClearContents
    arr = Application.WorksheetFunction.Transpose(d.keys)
    brr = d.items
    ReDim Preserve arr(1 To UBound(arr), 1 To 2)
    For i = 1 To UBound(arr)
        arr(i, 2) = brr(i - 1)
    Next
    Sheet3.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
    Set d = Nothing
    Set arr = Nothing
    Set brr = Nothing
End Sub

只观看

太棒了!谢谢楼上兄弟!!

susuperscorpis

楼主这段代码是什么意思啊？

aidixiao

谢谢分享。

只观看

对数据的合并,你可以看看结果,再理解!!

shiying19

经典。不错

Zamyi

http://club.excelhome.net/thread-698873-1-1.html
可以处理WorksheetFunction.Transpose(a)数组元素超过65536和某元素长度超过255不能使用的问题，而且速度也不错。

fbosunshine

还是不懂啊

wdtdzhi

没看懂，还是谢谢