动态相同项目行转列-优快云博客

本文链接：https://blog.youkuaiyun.com/kakakai110/article/details/146258080

需求：今天中午朋友圈有人问怎么把快速填充数据，我看了一下是行转列的问题，就写了一段宏代码，记录一下。

图1需求

分析一下需求：就是把相同项目的列数据转换为一行数据，每个项目数量并不固定（图1）。

话不多说直接上结果（图3），简单处理了一下，生成的原生的有点丑，哈哈哈

图2原生结果

图3最终结果

实现过程：

首先想到的是VLOOKUP函数，但是他只能查找到第一次出现的值，不符合要求，放弃。
写代码，代码如下

Sub MergeProjectData()
    
    
    Dim dict As Object
    Dim dataRng As Range, headerRow As Range
    Dim arrData, arrResult()
    Dim i As Long, j As Long, k As Long
    Dim projectCol As Long, maxCount As Long
    Dim key As Variant, delimiter As String
    Dim wsSource As Worksheet, wsDest As Worksheet
    
    ' ========== 用户配置 ==========
    Set wsSource = ThisWorkbook.Sheets("Sheet6")  ' 原始数据表
    Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSource) ' 结果输出到新表
    projectCol = 1   ' 项目名称所在列号（A列=1，B列=2...）
    delimiter = "|"  ' 明细分隔符
    ' =============================
    
    ' 获取数据区域
    Set headerRow = wsSource.UsedRange.Rows(1)
    Set dataRng = wsSource.UsedRange.Offset(1).Resize(wsSource.UsedRange.Rows.Count - 1)
    arrData = dataRng.Value
    
    ' 创建字典存储项目数据
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历原始数据
    For i = 1 To UBound(arrData, 1)
        Dim projectName As String
        projectName = arrData(i, projectCol)
        
        ' 跳过空项目
        If projectName = "" Then GoTo NextRow
        
        ' 记录最大明细行数
        If dict.Exists(projectName) Then
            dict(projectName)("count") = dict(projectName)("count") + 1
            If dict(projectName)("count") > maxCount Then maxCount = dict(projectName)("count")
        Else
            dict.Add projectName, CreateObject("Scripting.Dictionary")
            dict(projectName).Add "count", 1
            maxCount = Application.Max(maxCount, 1)
            
            ' 初始化项目首行数据
            For j = 1 To UBound(arrData, 2)
                dict(projectName).Add j, arrData(i, j)
            Next j
        End If
        
        ' 添加明细数据（从第二列开始）
        For j = 1 To UBound(arrData, 2)
            If j <> projectCol Then
                Dim currentKey As String
                currentKey = j & "_" & dict(projectName)("count")
                dict(projectName).Add currentKey, arrData(i, j)
            End If
        Next j
NextRow:
    Next i
    
    ' 构建结果数组
    ReDim arrResult(1 To dict.Count, 1 To UBound(arrData, 2) + (maxCount - 1) * (UBound(arrData, 2) - 1))
    
    ' 填充结果数据
    k = 1
    For Each key In dict.keys()
        ' 写入首列数据
        For j = 1 To UBound(arrData, 2)
            arrResult(k, j) = dict(key)(j)
        Next j
        
        ' 写入合并明细
        Dim detailCount As Long
        detailCount = dict(key)("count")
        
        For detailCount = 2 To dict(key)("count")
            For j = 1 To UBound(arrData, 2)
                If j <> projectCol Then
                    Dim targetCol As Long
                    targetCol = UBound(arrData, 2) + (detailCount - 2) * (UBound(arrData, 2) - 1) + (j - 1)
                    arrResult(k, targetCol) = dict(key)(j & "_" & detailCount)
                End If
            Next j
        Next detailCount
        k = k + 1
    Next key
    
    ' 输出结果
    With wsDest
        ' 写入标题（自动扩展列）
        headerRow.Copy .Range("A1")
        For i = 2 To maxCount
            For j = 1 To UBound(arrData, 2)
                If j <> projectCol Then
                    .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1) = _
                        headerRow.Cells(1, j).Value & i
                End If
            Next j
        Next i
        
        ' 写入数据
        .Range("A2").Resize(dict.Count, UBound(arrResult, 2)) = arrResult
        
        ' 格式优化
        .UsedRange.WrapText = False
        .UsedRange.EntireColumn.AutoFit
        .Cells(1, 1).Select
    End With
    
    MsgBox "合并完成！共处理 " & dict.Count & " 个项目", vbInformation
End Sub