çalma sayısını net olmayan kişi sayısına bölme

[çikos]

Arkadaşlar merhaba,
Bir makro yardımı istemiştim sağolsun veyselemre arkadaşımız aşağıdaki kodu göndermiş. Ben bu kodu denedim fakat tam olarak istediğim şeyi vermiyor. Benim bu koddan istediğim düet olan şarkıların çalma sayısını düet yapan kişi sayısına bölmesi.(örneğin sibel can-tarkan iki kişi ve çalma sayısı 3 ise 3/2 yapması. yani sibel can ve tarkanı ayrı satırlara yazarak sibel can'a 1,5 ve tarkan'a 1,5 olarak yazması). Bu kodu nasıl istediğim şekle dönüştürebiliriz?


Arkadaşlar bu konu çok acil lütfen yardımlarınızı esirgemeyin.

Ekte dosyamı gönderiyorum. dosyada benim yazdığım makro da mevcut. şimdiden çok çok teşekür ederim. saygılar..



Sub deneme()
Application.ScreenUpdating = False
sonSat = [N65536].End(3).Row
If sonSat = 1 Then Exit Sub
[aa1:aa65536].ClearContents
[AA1] = "Sıra"
[AA2] = "2": [AA3] = "3"
Range("AA2:AA3").AutoFill Destination:=Range("AA2:AA" & sonSat), Type:=xlFillDefault
sat = sonSat
For x = 2 To sonSat
If InStr(Cells(x, "N"), "-") Then
sanatcilar = Split(Cells(x, "N"), "-")
Cells(x, "N") = sanatcilar(0)

sanSay = UBound(sanatcilar) + 1
calmaSay = Round(Cells(x, "Q") / sanSay, 0)
kalan = Cells(x, "Q") - ((sanSay - 1) * calmaSay)
Cells(x, "Q") = kalan
Range(Cells(x, 1), Cells(x, "AA")).Interior.Color = vbYellow
For y = 1 To UBound(sanatcilar)
veri = Range(Cells(x, 1), Cells(x, "AA")).Value
sat = sat + 1
Range(Cells(sat, 1), Cells(sat, "AA")).Value = veri
Cells(sat, "N") = sanatcilar
Cells(sat, "Q") = calmaSay
Range(Cells(sat, 1), Cells(sat, "AA")).Interior.Color = vbRed
Next y
End If
Next x
Columns("A:AA").Sort Key1:=Range("AA2"), Order1:=xlAscending, Header:=xlGuess
Columns("AA").Delete
End Sub

 

[Korhan Ayhan]

Selamlar,

Sonucun hangi hücrelere yazılacağını belirtirseniz yardım almanız kolaylaşacaktır. Bu şekilde sorunuz askıda kalmış.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kod ile AA sütunundan itibaren listeleme yapabilirsiniz.

Sub DÜET_BUL_BÖL()
    For X = 2 To [N65536].End(3).Row
    If InStr(1, Cells(X, 14), "-") Then
    ADET = Split(Cells(X, 14), "-")
    If (UBound(ADET) + 1) = 2 Then
    Cells(X, "AA") = ADET(Y) & " " & Round(Cells(X, "Q") / (UBound(ADET) + 1), 2)
    Cells(X, "AB") = ADET(Y + 1) & " " & Round(Cells(X, "Q") / (UBound(ADET) + 1), 2)
    Else
    Cells(X, "AA") = ADET(Y) & " " & Round(Cells(X, "Q") / (UBound(ADET) + 1), 2)
    Cells(X, "AB") = ADET(Y + 1) & " " & Round(Cells(X, "Q") / (UBound(ADET) + 1), 2)
    Cells(X, "AC") = ADET(Y + 2) & " " & Round(Cells(X, "Q") / (UBound(ADET) + 1), 2)
    End If
    Else
    Cells(X, "AA") = Cells(X, 14) & " " & Cells(X, "Q")
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[çikos]

yardımınız için çok çok teşekkür ediyorum. iyi çalışmalar.

 

[çikos]

yazdığınız kodu denedim fakat hiç bir işlem yapmıyor. sadece "İşleminiz tamamlanmıştır." şeklinde bir mesaj veriyor.

yinede yardımınız için çok teşekkür ediyorum.