If Then Else yerine başka kod

[seddur]

Merhaba.Aşağıdaki kod ile Liste sayfası L sutunundaki benzersiz verileri Rapor sayfası B ve C sutunlarına kaydetiyorum.Ancak toplam 20 sutuna kayıt yapacağmdan If Then Else kullanmadan kısaca kodu nasıl düzenleyebiliriz.?

Dim S1, S2 As Worksheet
Dim i As Long, son As Long, son1 As Long, son2 As Long, sat As Long

Set S1 = Sheets("Liste")
Set S2 = Sheets("Rapor")
Application.ScreenUpdating = False
S2.Range("B2:K20").ClearContents
son = S1.[L65536].End(3).Row
sat = 2
For i = 2 To son
If WorksheetFunction.CountIf(S1.Range("L2:L" & i), S1.Cells(i, "L")) = 1 Then
If S1.Cells(i, 1) = "1" Then
S2.Cells(sat, "b").End(3)(2, 1) = S1.Cells(i, "L")
Else
If S1.Cells(i, 1) = "2" Then
S2.Cells(sat, "c").End(3)(2, 1) = S1.Cells(i, "L")
sat = sat + 1
End If: End If: End If
Next

 

[ÖmerFaruk]

Dosya paylaşsanız daha kolay olacak.

 

[seddur]

Dosya ektedir.

 

[ÖmerFaruk]

Gönderdiğiniz dosyanın çalışma şeklini ilk yazdığınız mesajla örtüştüremedim.
Mesajınzıda L sütununa bakacam demişsiniz
Dosyanızda Tarihe göre bir sorgu yapıyor. Ayrıca L sütununda da bir işlem yapıyorsunuz ama sanırım hatalı.

1. SORGULA butonuna bastığınızda sadece tarihe göre mi sorgulayacak? Başka bir kriter var mı?
2. Benim anladığım o tarihteki listenin sıralanması. Teyit ediniz.
3. Rapor sayfasındaki 1 nolu başlığın altına Liste sayfasının hangi sütunu yazılacak?
4. Aynı şekilde 2-3-4....20 nolu başlıkların altına Liste sayfasının hangi sütunu yazılacak?

 

[seddur]

1-Tarihe ve Liste sayfasındaki masa numarasına göre sorguluyor
2-Doğrudur o tarihdeki masa numaralarını listeleyecek.
3-Rapor sayfası 1 nolu başlığın altına Liste sayfasında masa numarası 1 olan satırların L sutunundaki değerlerini listeleyeek.
4-Aynı şekilde 2-3-4...20 nolu başlıkların altına Liste sayfası L sutunundaki değerleri benzersiz şekildemasa numarasına göre listeleyecek.Yani liste sayfasındaki veri hangi masa numarasına aitse Rapor sayfasında o numaranın bulunduğu sutuna listeleyecek.Listeleme sayısı en fazla 9 satır olarak varsayılmıştır.

 

[ÖmerFaruk]

Buton kodları aşağıdakiyle değiştirip deneme yaparmısınız.
Listenizde veriler çok az olduğu için ben sağlıklı deneyemedim.
Rastgele veri oluşturup denediğimde sonuçlar doğru gözüküyor.

Private Sub CommandButton2_Click()
    Dim S1, S2 As Worksheet
    Dim i As Long, a As Integer, b As Integer, k As Integer
    Dim Veri, Liste, Dict As Object
   
    Set S1 = Sheets("Liste")
    Set S2 = Sheets("Rapor")
    Application.ScreenUpdating = False
    S2.Range("B2:K10").ClearContents
    Veri = S1.Range("A2:L" & S1.Range("L" & Rows.Count).End(3).Row).Value
    Set Dict = CreateObject("Scripting.Dictionary")
   
    For i = 1 To 20
        ReDim Liste(1 To 9, 1 To 1)
        If i < 11 Then
            a = 1: b = i
        Else
            a = 11: b = i - 10
        End If
        For k = 1 To UBound(Veri)
            If Veri(k, 1) = i Then
                If Veri(k, 4) = CDate(Me.TextBox1) Then
                    If Not Dict.Exists(Veri(k, 12)) Then
                        Dict.Add Veri(k, 12), 1
                        Liste(Dict.Count, 1) = Veri(k, 12)
                        If Dict.Count=9 Then k=UBound(Veri)
                    End If
                End If
            End If
        Next k
        If Dict.Count > 0 Then S2.Range("A1").Offset(a, b).Resize(9, 1) = Liste: Dict.RemoveAll
    Next i
End Sub

 

[seddur]

Tamamdır sorunsuz çalışıyor.Sadece veri sayısı 9'u geçince aşağıdaki satır hata veriyor.Program çalışmıyor.Hata verme yerine 9 satırı listeleyip kalanları görmezden gelirse daha iyi olur.
Liste(Dict.Count, 1) = Veri(k, 12)

 

[ÖmerFaruk]

Önceki mesajımda verdiğim koda bir satır ilave ettim. Yeniden kopyalayın.

If Dict.Count=9 Then k=UBound(Veri)

 

[seddur]

Tamamdır,gerekli düzeltmeyi yaptım çalışıyor.Yardımlarınız için Teşekkür ederim.