竖列数据变横列

真情男人

请各位大神帮忙啊！着急！

约定的童话

文件上传一下啊

一把小刀闯天下

'假设A列有序，，，

Option Explicit

Sub test()
  Dim arr, i As Long, j As Long, m As Long, n As Long, p As Long
  arr = Range("a1:b" & [a1].End(xlDown).Row + 1)
  ReDim brr(UBound(arr, 1) / 2, 100) As String '最多支持100列输出
  For i = 1 To UBound(arr, 1) - 1
    n = n + 1
    brr(m, n) = arr(i, 2)
    If arr(i, 1) <> arr(i + 1, 1) Then
      If p < n Then p = n
      brr(m, 0) = arr(i, 1): m = m + 1: n = 0
    End If
  Next
  [e1].Resize(m + 1, p + 1) = brr
End Sub

真情男人

在手机上怎么上传附件？

约定的童话

真情男人 发表于 2019-10-16 14:42
在手机上怎么上传附件？

3楼给出代码了，会用吗？

真情男人

不会呀，我是菜鸟

真情男人

约定的童话 发表于 2019-10-16 14:44
3楼给出代码了，会用吗？

您能给我个做好的文件吗？谢谢！

约定的童话

真情男人 发表于 2019-10-16 14:49
您能给我个做好的文件吗？谢谢！

你得学会评分啊，哈哈

petergaod

Const linkChr = "@@@@"
Sub test()
    Dim dic, arrKeys, arrItems, arr
    Set dic = CreateObject("Scripting.dictionary")
    For i = 1 To [A65536].End(xlUp).Row
        dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) & IIf(dic(Cells(i, 1).Value) = "", "", linkChr) & Cells(i, 2)
    Next
    arrKeys = dic.keys
    arrItems = dic.items
    For i = 1 To dic.Count
        Cells(i, 5) = arrKeys(i - 1)
        arr = Split(arrItems(i - 1), linkChr)
        Cells(i, 6).Resize(1, UBound(arr) - LBound(arr) + 1) = arr
    Next
End Sub