[已解决]根据一个条件返回多个单元格内容 合并在一个单元格

kekiangel

根据一个条件返回多个单元格内容，  合并在一个单元格，     当灰色区域日期改变时相应的后边的内容变化，   如附件

最佳答案

月排行榜 / 总排行榜

JLxiangwei

2013-1-31 09:37

Sub test()
    Dim arr, x, y, k, arr1(1 To 1000, 1 To 2)
    Dim d As New Dictionary
    arr = Range("a1").CurrentRegion.Value
    For x = 2 To UBound(arr)
        If d.Exists(arr(x, 4)) Then
            k = d(arr(x, 4))
            arr1(k, 2) = arr1(k, 2) & arr(x, 3)
        Else
            y = y + 1
            d.Add arr(x, 4), y
            arr1(y, 1) = arr(x, 4)
            arr1(y, 2) = arr(x, 3)
        End If
    Next
    Range("h2:i65536").ClearContents
    Range("h2").Resize(y, 2) = arr1
End Sub

副本报表.rar (9.34 KB, 下载次数: 152)

2013-1-31 09:37 上传

点击文件名下载附件

用字典和数组写个，效率会高点
打开文件，点击按钮试试看。

跳转到最佳答案楼层

csmctjg

1. 
   
2. Sub aa()
   
3. Dim i
   
4. [I2] = ""
   
5. For i = 2 To [A65536].End(3).Row
   
6.     If Format(Cells(i, 4), "m-d") = Format([H2], "m-d") Then
   
7.         [I2] = [I2] & Cells(i, 3) & "(" & Cells(i, 2) & ")"
   
8.     End If
   
9. Next
   
10. End Sub
    

复制代码

JLxiangwei

Sub test()
    Dim arr, x, y, k, arr1(1 To 1000, 1 To 2)
    Dim d As New Dictionary
    arr = Range("a1").CurrentRegion.Value
    For x = 2 To UBound(arr)
        If d.Exists(arr(x, 4)) Then
            k = d(arr(x, 4))
            arr1(k, 2) = arr1(k, 2) & arr(x, 3)
        Else
            y = y + 1
            d.Add arr(x, 4), y
            arr1(y, 1) = arr(x, 4)
            arr1(y, 2) = arr(x, 3)
        End If
    Next
    Range("h2:i65536").ClearContents
    Range("h2").Resize(y, 2) = arr1
End Sub

副本报表.rar (9.34 KB, 下载次数: 152)

2013-1-31 09:37 上传

点击文件名下载附件

用字典和数组写个，效率会高点
打开文件，点击按钮试试看。

zyouong

副本报表.rar (10.65 KB, 下载次数: 88)

2013-1-31 17:18 上传

点击文件名下载附件

bauosj

可不可以再加一个条件呢

bauosj

一个条件返回多个单元格内容，  合并在一个单元格

可不可将一个条件变成２个，在线急