ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
一招顶“一万招”的懒人技巧 Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 129|回复: 10

[求助] 【已解决】请教老师,如何把相同名称的不同内容合并在一起

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-7-21 18:11 | 显示全部楼层 |阅读模式
本帖最后由 vbahappy 于 2021-7-21 19:04 编辑


    在实际工作中,我经常会遇到这个问题,就是相同的名称,有些内容不同,想把不同的内容合在同一单元格,
并且只保留一行,其他的删除;

原表

原表

效果图

效果图

内容合并.rar

6.66 KB, 下载次数: 8

TA的精华主题

TA的得分主题

发表于 2021-7-21 18:34 来自手机 | 显示全部楼层
看我的提问,标题里有逆透视的那个

TA的精华主题

TA的得分主题

发表于 2021-7-21 18:42 | 显示全部楼层
但愿能帮到你:

Sub byWanao()
    With Sheet1
        For x = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            If .Cells(x, 2) = "" Then Exit For
            For y = .Cells(Rows.Count, 2).End(xlUp).Row To x + 1 Step -1
                If .Cells(x, 2) = .Cells(y, 2) Then
                    .Cells(x, 4) = .Cells(x, 4) & "," & .Cells(y, 4)
                    .Cells(y, 4).EntireRow.Delete
                End If
            Next
        Next
    End With
End Sub

TA的精华主题

TA的得分主题

发表于 2021-7-21 18:43 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d = CreateObject("scripting.dictionary")
  6.   With Worksheets("sheet1")
  7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  8.     arr = .Range("a2:g" & r)
  9.   End With
  10.   For i = 1 To UBound(arr)
  11.     If Not d.exists(arr(i, 2)) Then
  12.       ReDim brr(1 To UBound(arr, 2))
  13.       For j = 1 To UBound(arr, 2)
  14.         brr(j) = arr(i, j)
  15.       Next
  16.     Else
  17.       brr = d(arr(i, 2))
  18.       brr(4) = brr(4) & "," & arr(i, 4)
  19.     End If
  20.     d(arr(i, 2)) = brr
  21.   Next
  22.   With Worksheets("sheet2")
  23.     .UsedRange.Offset(1, 0).Clear
  24.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
  25.   End With
  26. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2021-7-21 18:43 | 显示全部楼层
详见附件。

内容合并.rar

17.77 KB, 下载次数: 15

评分

参与人数 1鲜花 +1 收起 理由
vbahappy + 1 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-7-21 18:59 | 显示全部楼层

谢谢chxw68 老师的多次帮助,效果倒是这个效果,但我希望得出的结果覆盖原来的表,而不需要在SHEET2中,可以

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-7-21 19:04 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-7-21 19:16 | 显示全部楼层
就改一个字符,楼主要学会自己动手。

内容合并.rar

17.46 KB, 下载次数: 7

TA的精华主题

TA的得分主题

发表于 2021-7-21 19:42 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-7-21 22:00 | 显示全部楼层
Sub TestSub()
    Dim i, j, k, arr, brr, x, y, rng As Range
    Dim dic As Object, key As String, dickeys, Item, dicItems
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .Range("a1:g" & Cells(Rows.Count, "A").End(xlUp).Row)
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        For i = LBound(arr) + 1 To UBound(arr)
            key = arr(i, 2)
            If Not dic.Exists(key) Then
                k = k + 1
                For j = 1 To UBound(brr, 2)
                    brr(k, j) = arr(i, j)
                Next
                dic(key) = dic.Count + 1
            Else
                行号 = dic(key)
                brr(行号, 4) = brr(行号, 4) & "," & arr(i, 4)
            End If
        Next
        .[a2].Resize(1000, 10) = ""
        .[a2].Resize(k, UBound(brr)) = brr
    End With
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2021-7-29 00:57 , Processed in 0.074837 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表