koşullu numaralandırma

[gezgin-49]

Sayın üstadlarım, aşağıdaki şekilde bir tablom var, bu tabloda yaklaşık 2000 isim var, istediğimi aşağıda örnek olarak göstermeye çalışacağım.

A1=SIRA NO, = 1
B1=ADI SOYADI, = Kemal ……..
C1=İNGİLİZCE, = 1
D1=FRANSIZCA, =1
E1=RUSÇA, =1
F1=ALMANCA, =0
G1=ÇİNCE, =0
H1=ARAPÇA, =1
I1=İTALYANCA =0

yukarıdaki örneğe göre Kemal …...… isimli şahıs İngilizce, Fransızca, Rusça ve Arapça dillerini biliyor, başka bir sayfada

A1=SIRA NO, B1=ADI SOYADI, C1=BİLDİĞİ YABANCI DİL
A2=1 B2=Kemal ……. İngilizce
A3=1 B3=Kemal ……. Fransızca
A4=1 B4=Kemal ……. Rusça
A5=1 B5=Kemal ……. Arapça
yazsın ve ondan sonraki kişiye de bir sonraki numarayı aynı şekilde vermesini istiyorum,
Yardımlarınız için şimdiden hepinize teşekkür eder saygılar sunarım.

 

[ÖmerBey]

Merhaba,
Anladığım kadarıyla makro ile yapılabilir ama bir örnek dosya paylaşırsanız daha hızlı ve daha doğru cevap alırsınız.

 

[gezgin-49]

Sayın üstadım dosya ekleyemiyorum

eskiden düzeltme kısmı vardı, şimdi kaldırılmış galiba göremedim, onun için sorumda bir hata yapmışım
düzeltiyorum.


A1=SIRA NO, B1=ADI SOYADI, C1=BİLDİĞİ YABANCI DİL
A2=1 B2=Kemal ……. İngilizce
A3=2 B3=Kemal ……. Fransızca
A4=3 B4=Kemal ……. Rusça
A5=4 B5=Kemal ……. Arapça
yazsın ve ondan sonraki kişiye de bir sonraki numarayı aynı şekilde vermesini istiyorum,

 

[ÖmerBey]

Aşağıdaki kodu deneyiniz. Kırmızı renkle belirttiğim sayfa isimlerini kendi dosyanıza göre değiştiriniz.
Daha fazla yardıma ihtiyacınız olması durumunda lütfen örnek dosya paylaşınız.
İyi çalışmalar...

Sub kod()
Set s1 = Sheets("Sayfa1") 'Eski listenin yer aldığı sayfa
Set s2 = Sheets("Sayfa2") 'Yeni listenin oluşturulacağı sayfa
x = 1
For a = 2 To s1.Cells(Rows.Count, "B").End(3).Row
    For b = 3 To 9
        If s1.Cells(a, b) = 1 Then
            x = x + 1
            s2.Cells(x, "A") = x - 1
            s2.Cells(x, "B") = s1.Cells(a, "B")
            s2.Cells(x, "C") = s1.Cells(1, b)
        End If
    Next
Next
End Sub

 

[gezgin-49]

Aşağıdaki kodu deneyiniz. Kırmızı renkle belirttiğim sayfa isimlerini kendi dosyanıza göre değiştiriniz.
Daha fazla yardıma ihtiyacınız olması durumunda lütfen örnek dosya paylaşınız.
İyi çalışmalar...

Sub kod()
Set s1 = Sheets("Sayfa1") 'Eski listenin yer aldığı sayfa
Set s2 = Sheets("Sayfa2") 'Yeni listenin oluşturulacağı sayfa
x = 1
For a = 2 To s1.Cells(Rows.Count, "B").End(3).Row
    For b = 3 To 9
        If s1.Cells(a, b) = 1 Then
            x = x + 1
            s2.Cells(x, "A") = x - 1
            s2.Cells(x, "B") = s1.Cells(a, "B")
            s2.Cells(x, "C") = s1.Cells(1, b)
        End If
    Next
Next
End Sub

Sayın Üstadım Siz bir harikasınız. Allah sizden razı olsun, ne muradınız varsa versin, dünya ahiret sıkıntılarınızı gidersin inşallah. Amin

 

[ÖmerBey]

Amin, hepimizin inşallah.
İyi çalışmalar...

 

[gezgin-49]

sayın üstadım aynı konu ile ilgili bir sorum daha olacaktı,
yabancı dil kısmı 1 yerine 2 veya daha fazla olduğu zaman
örneğin İngilizce 3 olursa aynı kişiye ayrı sıra numarası alarak 3 kez ingilizce yazmasını istiyorum. buna göre

Sub kod()
Set s1 = Sheets("Sayfa1") 'Eski listenin yer aldığı sayfa
Set s2 = Sheets("Sayfa2") 'Yeni listenin oluşturulacağı sayfa
x = 1
For a = 2 To s1.Cells(Rows.Count, "B").End(3).Row
For b = 3 To 9
If s1.Cells(a, b) = 1 Then
x = x + 1
s2.Cells(x, "A") = x - 1
s2.Cells(x, "B") = s1.Cells(a, "B")
s2.Cells(x, "C") = s1.Cells(1, b)
End If
Next
Next
End Sub

kodlarında nasıl bir değişiklik yapabiliriz, saygılarımla

 

[ÖmerBey]

İlgili yerde sayı dışında bir değer varsa hata verecektir.

Sub kod()
Set s1 = Sheets("Sayfa1") 'Eski listenin yer aldığı sayfa
Set s2 = Sheets("Sayfa2") 'Yeni listenin oluşturulacağı sayfa
x = 1
For a = 2 To s1.Cells(Rows.Count, "B").End(3).Row
    For b = 3 To 9
        If s1.Cells(a, b) > 0 Then
            For c = 1 To s1.Cells(a, b)
                x = x + 1
                s2.Cells(x, "A") = x - 1
                s2.Cells(x, "B") = s1.Cells(a, "B")
                s2.Cells(x, "C") = s1.Cells(1, b)
            Next
        End If
    Next
Next
End Sub

 

[gezgin-49]

Sub kod()
Set s1 = Sheets("Sayfa1") 'Eski listenin yer aldığı sayfa
Set s2 = Sheets("Sayfa2") 'Yeni listenin oluşturulacağı sayfa
x = 1
For a = 2 To s1.Cells(Rows.Count, "B").End(3).Row
For b = 3 To 9
If s1.Cells(a, b) > 0 Then
For c = 1 To s1.Cells(a, b)
x = x + 1
s2.Cells(x, "A") = x - 1
s2.Cells(x, "B") = s1.Cells(a, "B")
s2.Cells(x, "C") = s1.Cells(1, b)
Next
End If
Next
Next
End Sub

Sayın Üstadım kodlarda renkli olarak gösterdiğim kısımda hata veriyor.

 

[gezgin-49]

Kodlarda bir hata yok, gayet güzel çalışıyor, benim sayfada bir yanlışlık vardı düzelttim. Allah Razı olsun üstadım, çok teşekkür ederim.