一维数据转换为二维数据

丙辰

各位老师，我想将一维数据转换为二维数据，求VBA的代码，非常感谢。
工作表："绩效汇总"是源数据；
工作表："一维转二维需要达到的结果"是想要达到的效果。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, m, n, p, cnt
  arr = Sheets("绩效汇总 ").[a1].CurrentRegion.Offset(1)
  ReDim brr(UBound(arr, 1), 1 To 30 + 2) As String  '最多支持30个月
  m = 0: n = 3
  For i = 1 To UBound(arr, 1) - 1
    m = m + 1
    If Len(arr(i, 2)) Then p = arr(i, 2)
    brr(m, 1) = p: brr(m, 2) = arr(i, 4): brr(m, n) = arr(i, 6)
    If arr(i, 1) <> arr(i + 1, 1) Then
      brr(0, n) = arr(i, 1): brr(0, 1) = "部门": brr(0, 2) = "姓名"
      cnt = m: m = 0: n = n + 1
    End If
  Next
  With Sheets("一维转二维需要达到的结果").[a1]
    .Resize(Rows.Count, n + 1).ClearContents
    .Resize(cnt + 1, n) = brr
  End With
End Sub

jiangxiaoyun

let
    源 = Excel.CurrentWorkbook(){[Name="表1"]}[Content],
    向下填充 = Table.FillDown(源,{"部门"}),
    删除的列 = Table.RemoveColumns(向下填充,{"序号", "总分", "绩效系数"}),
    已透视列 = Table.Pivot(删除的列, List.Distinct(删除的列[月份]), "月份", "绩效等级")
in
    已透视列


powerqery

丙辰

一把小刀闯天下 发表于 2019-3-17 14:24
Option Explicit

Sub test()

老师，如果2月份、3月份、4月份的人员不同的话，一维转二维之后，绩效等级对应不上相应的人名，详细看附件中，转换后，最后的人员绩效等级空着。

一把小刀闯天下

'你这是条件改变并不是代码有弊端，原附件每个月的人数都是一样的，而你并没有说明

'假设姓名没有重复，不然仅获取最后一次出现的（覆盖），也就是数据会丢失，，，

Option Explicit

Sub test()
  Dim arr, i, m, n, cnt, dic, p
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("绩效汇总 ").[a1].CurrentRegion.Offset(1)
  ReDim brr(UBound(arr, 1), 1 To 30 + 2) As String '最多支持30个月
  brr(0, 1) = "部门": brr(0, 2) = "姓名": n = 3
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, 2)) Then p = arr(i, 2)
    If Not dic.exists(arr(i, 4)) Then m = m + 1: dic(arr(i, 4)) = m
    brr(dic(arr(i, 4)), 1) = p
    brr(dic(arr(i, 4)), 2) = arr(i, 4)
    brr(dic(arr(i, 4)), n) = arr(i, 6)
    If arr(i, 1) <> arr(i + 1, 1) Then brr(0, n) = arr(i, 1): n = n + 1
  Next
  Call bsort(brr, 1, m, 1, n, 1)
  With Sheets("绩效按月统计").[a1]
    .Resize(Rows.Count, n + 1).ClearContents
    .Resize(m + 1, n) = brr
  End With
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) > arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
  Next j, i
End Function

sunshuangzhong

Sub testssz2()
'练习一维转二维20220512
Dim arr, brr, d1 As Object, d2 As Object, i%, imax%, h%, lh%, r%, k%, j As Integer
r = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("a1:f" & r)
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
'先获得列号
j = 2
For i = 2 To UBound(arr)
    If Not d1.exists(arr(i, 1)) Then
        j = j + 1
        d1(arr(i, 1)) = j
    End If
Next i

ReDim brr(1 To UBound(arr), 1 To j)
For i = 2 To UBound(arr)
    If Not d2.exists(arr(i, 4)) Then
        k = k + 1
        
        brr(k, 1) = arr(i, 2)
        If brr(k, 1) = "" Then
            brr(k, 1) = brr(k - 1, 1)
        End If
        
        brr(k, 2) = arr(i, 4)
        lh = d1(arr(i, 1))
        brr(k, lh) = arr(i, 6)
        d2(arr(i, 4)) = k
    Else
        h = d2(arr(i, 4))
        lh = d1(arr(i, 1))
        brr(h, lh) = arr(i, 6)
    End If   
Next i
Range("m2").Resize(k, j).Clear
Range("m2").Resize(k, j) = brr
Range("m1:n1") = Array("部门", "姓名")
Range("o1:Q1") = d1.keys

End Sub