tireleri ayrıştırıp çalma sayılarını tirenin ayrıştırdığı kişi sayısına bölen makro

[çikos]

Arkadaşlar herkese merhabalar.
çok acil yardımınıza ihtiyacım var. excelde bir makro yazmaya çalışıyorum çok uğraştım fakat bir türlü olmuyor.araştırmadığım yer kalmadı.

elimdeki raporlarda tire ile ayrılmış isimler var.örneğin Sibel can-tarkan gibi. benim yazdığım makroda bu tirelerle yazılmış düet isimler ayrıştırılıyor,renklendiriyor, alta yeni bir satır açılarak her iki isim satırınada aynı veriler yazıyor. yani tireden sonraki veriyi tüm değerleriyle alta satır açarak oraya yazıyor.

benim yapmak istediğim ise bu makro bu işlemleri yapıp her iki ismide ayrı satırda yazdıktan sonra "çalma sayısı" kolonunda yazan rakamı kaç kişi varsa o kişilere bölmesi. yani bir başka değişle tireleri saydırıp kaç kişi varsa çalma sayısı rakamını o kişilere bölmesi.

ekte size örnek raporumu ve yazdığım makroyu gönderiyorum.yardımınızı esirgemeyin yalvarıyorum. şimdiden herkese teşekkür ederim.

 

[veyselemre]

Merhaba, Aşağıdaki kodu deneyiniz.

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(y)
                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

 

[çikos]

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