DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Nasıl dosya yükleniyor buraya bulamadımMerhaba,
Aynı hücrede olacaksa, bu işlem için formül kullanmanızı tavsiye etmem, makro ile yapmak mantıklı olacaktır. Örnek dosya ekler misiniz, örnek üzerinden gidelim.
Sub bul()
Dim Sv As Worksheet, Sy As Worksheet
Dim ayr As String, i As Long, c As Range, Adr As String
Set Sv = Sheets("Aranacak veri")
Set Sy = Sheets("Aranılacak yer")
Application.ScreenUpdating = False
Sv.Select
Range("B2:B" & Rows.Count).ClearContents
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set c = Sy.[A:A].Find(Cells(i, "A"), , xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
If Cells(i, "B") = "" Then ayr = "" Else ayr = ";"
Cells(i, "B") = Cells(i, "B") & ayr & Sy.Cells(c.Row, "B")
Set c = Sy.[A:A].FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
Next i
End Sub
Aranacak veri sayfası A sütununa girilecek tüm veriler içindir.
Linki inceleyin.
Kod:Sub bul() Dim Sv As Worksheet, Sy As Worksheet Dim ayr As String, i As Long, c As Range, Adr As String Set Sv = Sheets("Aranacak veri") Set Sy = Sheets("Aranılacak yer") Application.ScreenUpdating = False Sv.Select Range("B2:B" & Rows.Count).ClearContents For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row Set c = Sy.[A:A].Find(Cells(i, "A"), , xlValues, xlWhole) If Not c Is Nothing Then Adr = c.Address Do If Cells(i, "B") = "" Then ayr = "" Else ayr = ";" Cells(i, "B") = Cells(i, "B") & ayr & Sy.Cells(c.Row, "B") Set c = Sy.[A:A].FindNext(c) Loop While Not c Is Nothing And c.Address <> Adr End If Next i End Sub