makro ile kaçıncı

[peleryn]

Herkese Merhabalar;

Ekli dosyadaki sorumda bir hücreye girilen örneğin 3 gibi bir rakamın 10234 gibi 5 haneli bir sayı içinde kaçıncı olduğunun bulunması ve bir başka sayfada bulunan bu sonuca karşılık gelen değerin alınması ile ilgili bir soru var.

NOT:Yazılacak kodun ANKET sayfasında tüm satırlar için çalışması gerekiyor.

İlgilenecek olan herkese çok teşekkür ederim..

 

[Orion1]

Dosyanız ektedir.

 

[peleryn]

Evren hocam hızlı yardımınız için teşekkür ederim.Ancak ihtiyacım olan yazılı olan rakamı sadece likert sayfasında arayıp yazması değil.Önce ilgili satırdaki kişi kodunu DATA sayfasında bulacağız sonra DATA sayfasında bu kişiye ait likert kodu (5 haneli) bulacağız ve daha sonra yazılı olan rakamın bu 5 haneli sayının kaçıncısı olduğunu bulduktan sonra likert sayfasından karşılığını ilgili hücreye yazacağız.

Daha açık bir şekilde :Kişi kodu 100 iken DATA sayfasındaki Likert Kod karşılığı 10234'tür yazdığım rakam 3 olsun bu rakam 10234 içerisinde 4. rakamdır o halde LİKERT sayfasındaki 4 rakamının karşılığı ilgili hücreye yazılır.Yazdığım rakam 0(sıfır) olsaydı 10234'ün 2. rakamı olacaktı ve Likert sayfasındaki 2 nin karşılığı istediğim sonuç olacaktı.

Tablolardan göreceğiniz gibi her kişi için bu değişiyor 105 kişi kodu olsaydı sayım 10239 olacaktı gibi..Eğer bu soruya makro yoluyla(gerektiğinde ben örnekte 5 madde için verdim ama sütun ekleyerek ya da çıkararak madde sayısını değiştirdiğimde de sonuç döndürebilen)bir çözüm bulabilirsem çok sevineceğim.İlginiz için tekrar teşekkür ederim.

 

[Orion1]

Buda makrolu çözüm.
Dosyanız ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim k As Range, sayi As Integer, kod, hcr As Range
If Intersect(Target, [A2:A65536,C2:G65536]) Is Nothing Then Exit Sub
On Error Resume Next
Set k = Sheets("DATA").Range("A2:A65536").Find(Cells(Target.Row, "A").Value, , xlValues, xlWhole)
If k Is Nothing Then
    Range("A" & Target.Row & ":M" & Target.Row).ClearContents
    Exit Sub
    Else: kod = k.Offset(0, 1).Value
End If
If Target.Column > 1 Then
    Target.Offset(0, 6).ClearContents
    If Target.Value = "" Then Exit Sub
    If Cells(Target.Row, "A").Value = "" Then Exit Sub
    sayi = InStr(1, kod, Target.Value)
    If sayi = 0 Then
        Exit Sub
        Else
        Set k = Sheets("LİKERT").Range("B2:B65536").Find(sayi, , xlValues, xlWhole)
        If Not k Is Nothing Then
            Target.Offset(0, 6).Value = k.Offset(0, 2).Value
        End If
    End If
End If
If Target.Column = 1 Then
    Range("I" & Target.Row & ":M" & Target.Row).ClearContents
    If Target.Value = "" Then Exit Sub
    For Each hcr In Range("C" & Target.Row & ":G" & Target.Row)
        sayi = 0
        sayi = InStr(1, kod, hcr.Value)
        If sayi > 0 And hcr.Value <> "" Then
            Set k = Sheets("LİKERT").Range("B2:B65536").Find(sayi, , xlValues, xlWhole)
            If Not k Is Nothing Then
                hcr.Offset(0, 6).Value = k.Offset(0, 2).Value
            End If
        End If
    Next
End If
End Sub

 

[peleryn]

Evren Hocam 3 nolu mesajda geniş bir açıklama yaptım ancak sizin mesajınızla aynı ana denk geldi sanırım.Malesef sorum bu çözümden biraz daha karmaşık umarım açıklamalarım yardımcı olabilmeniz için yeterli olur.

 

[Orion1]

Evren Hocam 3 nolu mesajda geniş bir açıklama yaptım ancak sizin mesajınızla aynı ana denk geldi sanırım.Malesef sorum bu çözümden biraz daha karmaşık umarım açıklamalarım yardımcı olabilmeniz için yeterli olur.

Dosyayı istediğiniz şekilde güncelledim.
4 numaralı mesajdan indirebilirsiniz.
Güle güle kullanın.

 

[peleryn]

Evren Hocam bütün gün dışardaydım aklım sizde ve dosyada zor attım kendimi eve.Ellerinize sağlık tek kelimeyle harika olmuş.Ufkumuzun ve bilgimizin genişlemesine yardımcı olduğunuz ve herşeyden önce varolduğunuz ve bıkmadan yorulmadan kendinizi paylaştığınız için tekrar tekrar teşekkür ederim.

 

[Orion1]

Evren Hocam bütün gün dışardaydım aklım sizde ve dosyada zor attım kendimi eve.Ellerinize sağlık tek kelimeyle harika olmuş.Ufkumuzun ve bilgimizin genişlemesine yardımcı olduğunuz ve herşeyden önce varolduğunuz ve bıkmadan yorulmadan kendinizi paylaştığınız için tekrar tekrar teşekkür ederim.

Rica ederim.
İyi çalışmalar.
Bir ses soluk çıkmayınca bende merak ettim doğrusu.