Otomatik Harf Verme

[aydinsert]

Merhaba Arkadaşlar,
elimde ekteki gibi bir dosya mevcut. Dosyada iller aldıkları puana göre sıralı. H sütununda harf skalası var. Yapmak istediğim otomatik olarak harf sklasanın altında yazan sayı kadar soldaki illere harf vermek. Yani ilk sıradaki ilin yanına A yazacak sonraki 4 ile B yazacak daha sonraki 13 ile ise C.
Destekleriniz için şimdiden teşekkürler.

 

[netzone]

Merhaba,
Göndermiş olduğunuz tabloda işlem sonrası; sonucu nerede nasıl almak istediğinizi manuel olarak bir kaç örnek ile doldurursanız, girilen değerler doğrultusunda çözüm üretmeye çalışalım.

iyi çalışmalar.

 

[erkan1903]

Merhaba,
F2 hücresine şu formülü yazıp aşağı doğru çekin. Aklıma gelen ilk yol bu oldu.Ayrıca I2-M2 arası hücrelerdeki sayılar değişince formül yine çalışır.
Biraz uzun oldu formül
İyi çalışmalar

=EĞER(VE($C2>$I$2;$C2<=$I$2+$J$2);$J$1;EĞER(VE($C2>$I$2+$J$2;$C2<=$I$2+$J$2+$K$2);$K$1;EĞER(VE($C2>$I$2+$J$2+$K$2;$C2<=$I$2+$J$2+$K$2+$L$2);$L$1;EĞER(VE($C2>$I$2+$J$2+$K$2+$L$2;$C2<=$I$2+$J$2+$K$2+$L$2+$M$2);$M$1;$I$1))))

 

[1Al2Ver]

Merhaba,

Formülden ben de faydalandım, teşekkür ederim,

Sayın erkan1903'ün formülünü biraz sadeleştirip kullandım ;

=EĞER(VE($C2>$I$2;$C2<=$I$2+$J$2);$J$1;EĞER(VE($C2>$I$2+$J$2;$C2<=TOPLA($I$2:$K$2));$K$1;EĞER(VE($C2>TOPLA($I$2:$K$2);$C2<=TOPLA($I$2:$L$2));$L$1;EĞER(VE($C2>TOPLA($I$2:$L$2);$C2<=TOPLA($I$2:$M$2));$M$1;$I$1))))

 

[aydinsert]

ilginiz için teşekkürler. Sayın netzone kısaca: f2 ye A yazacak f3,f4,f5 ve f6 ya ise B yazacak aşağıya doğru devam edecek. Çünkü A harfinden bir tane b harfinden ise 4 tane olacak.

 

[YUSUF44]

Makrolu çözüm isterseniz aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub harf()
son = Cells(Rows.Count, "F").End(3).Row + 1
Range("F2:F" & son) = ""
For i = 9 To 13
For j = 1 To Cells(2, i)
Cells(Cells(Rows.Count, "F").End(3).Row + 1, "F") = Cells(1, i)
Next
Next
End Sub

 

[aydinsert]

sayın Yusuf44 ve erkan1903 çok teşekkür ediyorum ikisi de işe yaradı.

 

[aydinsert]

Makrolu çözüm isterseniz aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub harf()
son = Cells(Rows.Count, "F").End(3).Row + 1
Range("F2:F" & son) = ""
For i = 9 To 13
For j = 1 To Cells(2, i)
Cells(Cells(Rows.Count, "F").End(3).Row + 1, "F") = Cells(1, i)
Next
Next
End Sub

Şunu belirtmeliyim; sıralama bozulunca verilen harfte bozuluyor.

 

[YUSUF44]

Sorunun ne olduğunu anlamadım. Örnekle gösterirseniz iyi olur.

 

[aydinsert]

Merhaba Yusuf Bey demek istediğim normalde liste büyükten küçüğe doğru sıralı. Sıralama karışık olursa yani en büyük en üstte değilde aralarda olursa macro yanlış çalışıyor.

 

[YUSUF44]

Lütfen örnek dosya ile gösterin. "Makro yanlış çalışıyor" demişsiniz ama ne önceki sorularınızda ne de örnek dosyanızda buna ilişkin bir uyarı ya da istek bulunmuyor. Makro siz neyi istediyseniz onu yapıyor, yanlış çalışmıyor. Eğer başka bir şey istiyorsanız lütfen ne istediğinizi daha açık bir şekilde belirtiniz.

 

[aydinsert]

Demek istediğim şu: Normalde kod düzgün onda bir sorun yok Yusuf Bey. Sorun en büyük değer ilk sırada değilse yani sıralama karışıksa verdiği harf doğru olmuyor. İlk sırada hangi il varsa A yı ona veriyor. Dosya ekte. Yanlış anlaşılma olduysa kusura bakmayın.

 

[YUSUF44]

Bu durumda nasıl olacağını manuel yazıp paylaşır mısınız?

 

[Korhan Ayhan]

Alternatif olarak aşağıdaki kodu deneyiniz.

Option Explicit

Sub HARF_NOTU()
    Dim Veri As Range, WF As WorksheetFunction, Kacinci As Integer
    Dim X As Byte, Sayi As Double, Bul As Range, Adres As String, Say As Integer
    
    Set WF = WorksheetFunction
    
    Range("F2:F" & Rows.Count).ClearContents
    
    For Each Veri In Range("I2:M2")
        For X = 1 To Veri.Value
            Kacinci = Kacinci + 1
            Sayi = WF.Large(Range("E:E"), Kacinci)
            Say = WF.CountIf(Range("E:E"), Sayi)
            Select Case Say
                Case 1
                    Set Bul = Range("E:E").Find(Sayi, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Offset(0, 1) = Veri.Offset(-1, 0)
                    End If
                Case Is > 1
                    Set Bul = Range("E:E").Find(Sayi, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Adres = Bul.Address
                        Do
                            Bul.Offset(0, 1) = Veri.Offset(-1, 0)
                            Set Bul = Range("E:E").FindNext(Bul)
                        Loop While Not Bul Is Nothing And Bul.Address <> Adres
                    End If
            End Select
        Next
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[aydinsert]

Korhan Bey, Yusuf Bey, desteğiniz için teşekkürler son kod işimi çözdü.