Bire çok ilişki

[merakli_72]

mrb,
Açıklama dosya içindedir,
Teşekkürler

 

[excel_ance]

selamlar

arkadaşım ekteki dosyayı inceleyiniz umarım işineze yarar

 

[excel_ance]

dosya ektedir

 

[merakli_72]

selam
eki unutmuşsunuz

 

[merakli_72]

Sayın excel_ance
sanırım yanlış anlaşıldım, N sutununda yer alan fiş no larının uygun şekilde C sutununa gelmesi gerekiyor, seçilenin değil hepsinin

 

[uzmanamele]

merhaba

ek dosya işinizi görür mü?

Sub sirala()
    Range("M2:N65536").Select
    ActiveWorkbook.Worksheets("veri").Sort.SortFields.Add Key:=Range("M2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("veri").Sort
        .SetRange Range("M2:N76")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub FisNoBul()
Application.ScreenUpdating = False
Call sirala
    Range("C2:C65536").ClearContents
ss = Range("a65536").End(3).Row
For i = 2 To ss
            adet = Application.WorksheetFunction.CountIf(Range("m2:m65536"), Cells(i, "a").Value)
            
If adet > 0 Then
    Columns("M:M").Select
    satir = Selection.Find(What:=Cells(i, "a"), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Row
FisNo = ""
For j = satir To satir + adet - 1
FisNo = FisNo & Cells(j, "n") & ","
Next j
Cells(i, "c") = FisNo
End If
adet = ""
Next i
End Sub

 

[merakli_72]

çok teşekkür ederim,
emeğinize sağlık