[已解决]查找对应的值的问题，麻烦高手们帮个忙

luckberry

6c5VXr2c.rar (6.81 KB, 下载次数: 1)

2010-5-5 16:27 上传

点击文件名下载附件
查找对应的值的问题，麻烦高手们帮个忙

最佳答案

月排行榜 / 总排行榜

过江龙

2010-5-5 17:26

加两个循环即可：

Private Sub 查找_Click()
With Sheets("Sheet1")
y = [A65536].End(xlUp).Row
For i = 2 To y
    For Each c In .Range("A2:A" & .[A65536].End(xlUp).Row)
        If c = Cells(i, 1).Value Then
            x = c.Row
            If Cells(i, 2) = "" Then
             Cells(i, 2).Value = .Cells(x, 2).Value
            Else
             Cells(i, 2).Value = Cells(i, 2).Value & "，" & .Cells(x, 2).Value
            End If
        End If
    Next c
 Next
End With
End Sub

5W0qkBRB.rar (9.85 KB, 下载次数: 10)

2010-5-5 17:25 上传

点击文件名下载附件
查找对应的值的问题，麻烦高手们帮个忙

跳转到最佳答案楼层

Zipall

BZf4m73N.rar (13.15 KB, 下载次数: 2)

2010-5-5 17:21 上传

点击文件名下载附件
查找对应的值的问题，麻烦高手们帮个忙

Option Base 1
Sub 汇总()
    a = Sheets("sheet1").Cells(2, 1).Resize(Sheets("sheet1").Cells(65536, 1).End(xlUp).Row - 1, 2).Value
    Set d = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(a)
        If d.Exists(a(r, 1)) Then
            d.Item(a(r, 1)) = d.Item(a(r, 1)) & "," & a(r, 2)
        Else
            d.Add a(r, 1), a(r, 2)
        End If
    Next
    For r = 2 To Cells(65536, 1).End(xlUp).Row
        Cells(r, 2) = d.Item(Cells(r, 1).Value)
    Next
End Sub

过江龙

加两个循环即可：

Private Sub 查找_Click()
With Sheets("Sheet1")
y = [A65536].End(xlUp).Row
For i = 2 To y
    For Each c In .Range("A2:A" & .[A65536].End(xlUp).Row)
        If c = Cells(i, 1).Value Then
            x = c.Row
            If Cells(i, 2) = "" Then
             Cells(i, 2).Value = .Cells(x, 2).Value
            Else
             Cells(i, 2).Value = Cells(i, 2).Value & "，" & .Cells(x, 2).Value
            End If
        End If
    Next c
 Next
End With
End Sub

5W0qkBRB.rar (9.85 KB, 下载次数: 10)

2010-5-5 17:25 上传

点击文件名下载附件
查找对应的值的问题，麻烦高手们帮个忙

帅

[em02][em02]学习

luckberry

感谢大哥的帮忙，万分感激中！！！

过江龙

大哥，举手之劳，还是评一哈最佳噻。

luckberry

QUOTE:

以下是引用过江龙在2010-5-5 17:26:00的发言：

加两个循环即可：

Private Sub 查找_Click()
With Sheets("Sheet1")
y = [A65536].End(xlUp).Row
For i = 2 To y
    For Each c In .Range("A2:A" & .[A65536].End(xlUp).Row)
        If c = Cells(i, 1).Value Then
            x = c.Row
            If Cells(i, 2) = "" Then
             Cells(i, 2).Value = .Cells(x, 2).Value
            Else
             Cells(i, 2).Value = Cells(i, 2).Value & "，" & .Cells(x, 2).Value
            End If
        End If
    Next c
 Next
End With
End Sub

不知道该如何设置为最佳答案！！！