求助各位大神 如何把多个相同数据 每行的不同内容 按表头 合并

1336034675

dambcer 发表于 2022-12-29 17:55
pq处理

不懂这个如何操作？ 我要是在最后面再添加几列 不知道结果后面是否能够实现合并····

1336034675

gwjkkkkk 发表于 2022-12-29 18:37
请参考附件。。。

这个不错，可以按表头实现····

LIUZHU

1336034675 发表于 2022-12-30 09:49
我后面增加几列的话  后面没数据····

当然了，我以为你的数据知道H列，所以用数组获取的单元格范围，列是固定的，行时不固定的

1336034675

LIUZHU 发表于 2022-12-30 10:30
当然了，我以为你的数据知道H列，所以用数组获取的单元格范围，列是固定的，行时不固定的

有没有办法 能按列 表头名称实现 而且不固定增加  不用计算天数  只要合并到一行 用分号隔开即可  

LIUZHU

1336034675 发表于 2022-12-30 11:06
有没有办法 能按列 表头名称实现 而且不固定增加  不用计算天数  只要合并到一行 用分号隔开即可

你指的是所有的内容合并到一行，包括天数，都用分号隔开？

zpy2

1336034675 发表于 2022-12-30 11:06
有没有办法 能按列 表头名称实现 而且不固定增加  不用计算天数  只要合并到一行 用分号隔开即可

https://club.excelhome.net/forum.php?mod=viewthread&tid=1641720&fromguid=hot&extra=&mobile&_dsign=c1f91ec0

supermouse24

Sub dic_mothod()


    Dim brr(), crr()
   
'名称去重并加入字典
    With Worksheets("数据源")
        arr = .[a1].CurrentRegion.Value
        title_arr = .[a1].CurrentRegion.Resize(1, UBound(arr, 2)).Value
    End With
    Set dic = CreateObject("scripting.dictionary")
   
    dic_num = UBound(arr, 2)
    ReDim brr(2 To dic_num), crr(2 To dic_num)

    For irow = 2 To UBound(arr)
        name_ = arr(irow, 1)
        If Not dic.exists(name_) Then
            dic(name_) = brr
        End If
    Next

'对应的名字下累计做过的事情
    For irow = 2 To UBound(arr, 1)
        name_ = arr(irow, 1)
        end_ = UBound(dic(name_))
        For i = 2 To end_ - 1
            crr(i) = dic(name_)(i) & arr(irow, i) '累计文字
        Next
        crr(end_) = dic(name_)(end_) + arr(irow, end_) '累计数字
        
        dic(name_) = crr
    Next
'打印
    With Worksheets("结果")
        .[a:h].Clear
        .[a1].Resize(1, UBound(arr, 2)) = title_arr
        .[a1].Resize(1, UBound(arr, 2)).Style = "title" '新建单元格样式，并命名为 title。懒得写代码
        irow = 2
        For Each k In dic.keys
            .Rows(irow).RowHeight = 75 '行宽统一为75。比较输入
            .Cells(irow, 1) = k
            .Cells(irow, 1).Style = "结果"
            .Cells(irow, 2).Resize(1, UBound(arr, 2) - 1) = dic(k)
            .Cells(irow, 2).Resize(1, UBound(arr, 2) - 1).Style = "结果" '新建单元格样式，并命名为 结果。懒得写代码
            irow = irow + 1
        Next
        .[a:h].EntireColumn.AutoFit '自动列宽
    End With
   
   
End Sub

附件直接能用了。我已经设置好单元格样式。

supermouse24

逻辑：
名称去重并加入字典
对应的名字下累计做过的事情
1.累计文字
2.累计数字
打印
'新建单元格样式，并命名为 结果。懒得写代码

Sub dic_mothod()


    Dim brr(), crr()
   

    With Worksheets("数据源")
        arr = .[a1].CurrentRegion.Value
        title_arr = .[a1].CurrentRegion.Resize(1, UBound(arr, 2)).Value
    End With
    Set dic = CreateObject("scripting.dictionary")
   
    dic_num = UBound(arr, 2)
    ReDim brr(2 To dic_num), crr(2 To dic_num)

    For irow = 2 To UBound(arr)
        name_ = arr(irow, 1)
        If Not dic.exists(name_) Then
            dic(name_) = brr
        End If
    Next


    For irow = 2 To UBound(arr, 1)
        name_ = arr(irow, 1)
        end_ = UBound(dic(name_))
        For i = 2 To end_ - 1
            crr(i) = dic(name_)(i) & arr(irow, i)
        Next
        crr(end_) = dic(name_)(end_) + arr(irow, end_)
        
        dic(name_) = crr
    Next

    With Worksheets("结果")
        .[a:h].Clear
        .[a1].Resize(1, UBound(arr, 2)) = title_arr
        .[a1].Resize(1, UBound(arr, 2)).Style = "title"
        irow = 2
        For Each k In dic.keys
            .Rows(irow).RowHeight = 75
            .Cells(irow, 1) = k
            .Cells(irow, 1).Style = "结果"
            .Cells(irow, 2).Resize(1, UBound(arr, 2) - 1) = dic(k)
            .Cells(irow, 2).Resize(1, UBound(arr, 2) - 1).Style = "结果"
            irow = irow + 1
        Next
        .[a:h].EntireColumn.AutoFit
    End With
   
   
End Sub

1336034675

LIUZHU 发表于 2022-12-30 11:27
你指的是所有的内容合并到一行，包括天数，都用分号隔开？

是的   相信对你来说应该可以···   谢谢你的回复   我这边已经解决了···

1336034675

shiruiqiang 发表于 2022-12-30 09:50
没详细数据，不好说。代码已经排查第一项，其余关键字没看见不好判断。建议各种情况的发上来。其次，可 ...

我这边用简单的函数 已解决 谢谢你的回复····