Şimdilik sadece Rütbeye göre sıralı olarak eklendi
diğerlerini daha uygun bir zamanda çözmeye çalışacağım.
değişiklikler
1 - Kontrol sayfasındaki sicil alanının türünü (F sütunu) metin olarak belirleyin
2 - Veri sayfasındaki sicil alanının türünü (B sütunu) metin olarak belirleyin
3 - Kontrol sayfasına Rütbe için sıra no eklendi.

Dim Sql As String

Dim ADO_RS As ADODB.Recordset

Dim ADO_CN As ADODB.Connection



SQL = "SELECT [VERi$].[F1], [VERi$].[F2], [VERi$].[F5], [VERi$].[F3], [VERi$].[F4],1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 " & _

      "FROM [KONTROL$B2:C] INNER JOIN ((([VERi$] " & _

                      "LEFT JOIN [KONTROL$E2:E]  ON [VERi$].[F6] = [KONTROL$E2:E].[F1]) " & _

                      "LEFT JOIN [KONTROL$F2:F]  ON [VERi$].[F5] = [KONTROL$F2:F].[F1]) " & _

                      "LEFT JOIN [KONTROL$G2:G]  ON [VERi$].[F2] = [KONTROL$G2:G].[F1]) ON [KONTROL$B2:C].[F2] = [VERi$].[F5] " & _

      "WHERE ([VERi$].[F1]  Is Not Null) and (([KONTROL$E2:E].[F1]) Is Null) and (([KONTROL$F2:F].[F1]) Is Null) and (([KONTROL$G2:G].[F1]) Is Null) " & _

      "ORDER BY Clng([KONTROL$B2:C].[F1])"





Set ADO_RS = New ADODB.Recordset

Set ADO_CN = New ADODB.Connection



'sonStr = ws.Range("A" & Rows.Count).End(3).Row + 1



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _

                          ";extended properties=""excel 12.0;hdr=no;IMEX=1"""

ADO_CN.Open

ADO_RS.Open SQL, ADO_CN, 3, 1

'

SonStr = Worksheets(Me.ComboBox1.Value).Cells(Worksheets(Me.ComboBox1.Value).Rows.Count, 2).End(xlUp).Row + 1

  

Worksheets(Me.ComboBox1.Value).Range("A7:AI" & SonStr).UnMerge

Worksheets(Me.ComboBox1.Value).Range("A7:AI" & SonStr).ClearContents





'  Eğer Hiç Kayıt Yoksa

If ADO_RS.RecordCount = 0 Then

    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

    GoTo skipfile:

End If

ADO_RS.MoveLast

ADO_RS.MoveFirst

ADO_RS.MoveNext



Worksheets(Me.ComboBox1.Value).Range("A7").CopyFromRecordset ADO_RS

skipfile:

ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing

Bende bitmiş halini ekleyeyim.Arama için alanları karıştırmışım.Renk için olayına girmedim.

Private Sub SayfayýHazýrla_Click()



Dim bul As Range, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, arr2()

Dim arr(), i As Long, son As Long, dogru As Boolean, say As Long, soncomboSayfa As Long

Application.ScreenUpdating = False

If Len(Trim(Me.ComboBox1.Value)) = 0 Then

    MsgBox "Sayfa seciniz...", vbCritical, "Safa sec"

    Exit Sub

End If



Set s1 = ThisWorkbook.Sheets("VERÝ") 'Veri

Set s2 = ThisWorkbook.Sheets("KONTROL") 'Kontrol

Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value)

son = s1.Cells(Rows.Count, 1).End(3).Row

soncomboSayfa = s3.Cells(Rows.Count, "Aj").End(3).Row

If soncomboSayfa < 7 Then soncomboSayfa = 7



If son < 2 Then GoTo son

ReDim arr(1 To son, 1 To 5)

say = 1

On Error Resume Next

s3.Range("A7:AJ" & Rows.Count).UnMerge

s3.Range("A7:AJ" & Rows.Count).ClearContents

s3.Range("A7:AJ" & Rows.Count).Borders.LineStyle = xlNone

On Error GoTo 0

For i = 2 To son

    dogru = False

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 2).Value, , , 1) 'Sicil

    If Not bul Is Nothing Then dogru = True

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 5).Value, , , 1) 'ad

    If Not bul Is Nothing Then dogru = True

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 6).Value, , , 1) 'soyad

    If Not bul Is Nothing Then dogru = True

    If dogru = False Then

        arr(say, 1) = say

        arr(say, 2) = s1.Cells(i, 2).Value + 0

        arr(say, 3) = s1.Cells(i, 5).Value

        arr(say, 4) = s1.Cells(i, 3).Value

        arr(say, 5) = s1.Cells(i, 4).Value

        say = say + 1

    End If

Next

If say > 1 Then

    s3.Range("A7").Resize(say, UBound(arr, 2)).Value = arr

    soncomboSayfa = s3.Cells(Rows.Count, 1).End(3).Row

    s3.Range("F7:Ai" & soncomboSayfa).Value = 1

    s3.Range("F7:AJ" & soncomboSayfa).Borders.LineStyle = 1

    ReDim arr2(1 To soncomboSayfa, 1 To 1)

    say = 0

    For i = 7 To soncomboSayfa

        say = say + 1

        arr2(say, 1) = WorksheetFunction.Sum(s3.Range(s3.Cells(i, "F"), s3.Cells(i, "Ai")))

    Next

        s3.Range("AJ7").Resize(soncomboSayfa, 1).Value = arr2

        s3.Range("B7:Aj" & soncomboSayfa).Sort s3.Range("B7"), , , , , , , xlNo

End If



son:

Application.ScreenUpdating = True

Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set bul = Nothing: Erase arr: Erase arr2

MsgBox "Bitti", vbInformation, "Bitti"



End Sub

---

Tabii veri B sütununda boş karakterler olduğu için az bulmuş onada bakayım

rütbeye göre mi sıralanacak yoksa büroya göre mi?

Değerli Hocalarım her iki örnekte de AJ sütunu temizlenmiyor sabit kalıyor Oysa A7 : AJ satırıdan son dolu satıra kadar önce silmeli daha sonra B sutunu dolu olan satırlar için 1111111111111111111111111 30 adet 1 yazıktan sonra AJ sütununa toplam 30 yazacak ama bu 1 lerden biri 0 olunca 29 a düşecek iki ayrı bir sıfır yazınca AJ28 olacak mavi renk olursa dikkat çekiyor.

Sayfanın sonunda makul boşluk olduktan sonra 5 li imza açılacak

Hangi örnek uygun olursa bundan sonra o örnek üzerinden devam etmek isterim. Çünkü dosyayı anlık başka bilgisayarlarda çalıştıracağımız için dosyanın sorunsuz çalışması lazım

Valilik olurundan sonra Misal Ocak ayı sayfasında yani ocak ayına ait puantajı HER AY Kontrol sayfasındaki 1. Liste 2. Liste diye 10.Listeye kadar devam eden sütınlar ve aynı adda sayfalar var
Misal Kontrol sayfası 1.Liste sütununda yazan büro isimleri ne ise o büro isimlerinde çalışan personel 1.Liste sayfasına aynı formatla kopyalanacak. Tek fark 1.Liste sayfasında yazılı olanlar aynı puantaja sahip Bürolar olacak
Yani Kontrol sayfası 1.Liste sütununda Personel Büro İdari İşler Büro Adli İşlemler Büro yazıyorsa
1.Liste sayfasına sadece bu bürolarda çalışan personel ocak sayfasından kopyalanıp comment açıklama bilgisi ile yapışacak
Bir büro birden fazla liste ve sayfada olabilir

Buna göre hangi örnekle devam etmem daha uygun olur

---

(19/11/2020, 23:55)berduş yazdı: rütbeye göre mi sıralanacak yoksa büroya göre mi?

Önce rütbeye göre sıralanacak sıralı şekli kontrol b sütununda var
rütbeler eşit ise sicili önce olan üstte olacak 375000 üstte 375001 onun altında olacak

s3.Range("A7:AJ" & Rows.Count).ClearContents bu kod her iki koddada var ve temizler.
Öncekide31 adet buluyordu buda aynı.
Deneyebilirsiniz.

Private Sub SayfayýHazýrla_Click()



Dim bul As Range, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, arr2(), dic As Object

Dim arr(), i As Long, son As Long, dogru As Boolean, say As Long, soncomboSayfa As Long

Dim sonKontrolSicil As Long, varmi As Boolean, k As Long



varmi = True



Application.ScreenUpdating = False

If Len(Trim(Me.ComboBox1.Value)) = 0 Then

    MsgBox "Sayfa seciniz...", vbCritical, "Safa sec"

    Exit Sub

End If

Set dic = CreateObject("Scripting.Dictionary")

Set s1 = ThisWorkbook.Sheets("VERÝ")

Set s2 = ThisWorkbook.Sheets("KONTROL")

Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value)

son = s1.Cells(Rows.Count, 1).End(3).Row

soncomboSayfa = s3.Cells(Rows.Count, "Aj").End(3).Row

sonKontrolSicil = s2.Cells(Rows.Count, "F").End(3).Row

If soncomboSayfa < 7 Then soncomboSayfa = 7



If son < 2 Then GoTo son

If sonKontrolSicil < 2 Then

varmi = False

GoTo var



End If



For i = 2 To son

    If Not dic.exists(s1.Cells(i, 2).Value + 0) Then dic.Add s1.Cells(i, 2).Value + 0, s1.Cells(i, 2).Value + 0

Next

var:

ReDim arr(1 To son, 1 To 5)

say = 1

On Error Resume Next

s3.Range("A7:AJ" & Rows.Count).UnMerge

s3.Range("A7:AJ" & Rows.Count).ClearContents

s3.Range("A7:AJ" & Rows.Count).Borders.LineStyle = xlNone

On Error GoTo 0

For i = 2 To son

    dogru = False

    If varmi = True Then

        For k = 2 To sonKontrolSicil

            If s2.Cells(k, "F").Value <> "" Then

                If s2.Cells(k, "F").Value + 0 = dic(s1.Cells(i, 2).Value + 0) Then

                    dogru = True

                    GoTo 10

                End If

            End If

        Next

    End If

    

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 5).Value, , , 1)

    If Not bul Is Nothing Then dogru = True

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 6).Value, , , 1)

    If Not bul Is Nothing Then dogru = True

10

    If dogru = False Then

        arr(say, 1) = say

        arr(say, 2) = s1.Cells(i, 2).Value + 0

        arr(say, 3) = s1.Cells(i, 5).Value

        arr(say, 4) = s1.Cells(i, 3).Value

        arr(say, 5) = s1.Cells(i, 4).Value

        say = say + 1

    End If

Next

If say > 1 Then

    s3.Range("A7").Resize(say, UBound(arr, 2)).Value = arr

    soncomboSayfa = s3.Cells(Rows.Count, 1).End(3).Row

    s3.Range("F7:Ai" & soncomboSayfa).Value = 1

    s3.Range("F7:AJ" & soncomboSayfa).Borders.LineStyle = 1

    ReDim arr2(1 To soncomboSayfa, 1 To 1)

    say = 0

    For i = 7 To soncomboSayfa

        say = say + 1

        arr2(say, 1) = WorksheetFunction.Sum(s3.Range(s3.Cells(i, "F"), s3.Cells(i, "Ai")))

    Next

        s3.Range("AJ7").Resize(soncomboSayfa, 1).Value = arr2

        s3.Range("B7:Aj" & soncomboSayfa).Sort s3.Range("B7"), , , , , , , xlNo

End If



son:

Application.ScreenUpdating = True

Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set bul = Nothing: Erase arr: Erase arr2: Set dic = Nothing

MsgBox "Bitti", vbInformation, "Bitti"



End Sub

Sql kodunu aşağıdaki gibi değiştirip dener misiniz?

SQL = "SELECT [VERi$].[F1], [VERi$].[F2], [VERi$].[F5], [VERi$].[F3], [VERi$].[F4],1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 " & _

      "FROM [KONTROL$B2:C] INNER JOIN ((([VERi$] " & _

                      "LEFT JOIN [KONTROL$E2:E]  ON [VERi$].[F6] = [KONTROL$E2:E].[F1]) " & _

                      "LEFT JOIN [KONTROL$F2:F]  ON [VERi$].[F5] = [KONTROL$F2:F].[F1]) " & _

                      "LEFT JOIN [KONTROL$G2:G]  ON [VERi$].[F2] = [KONTROL$G2:G].[F1]) ON [KONTROL$B2:C].[F2] = [VERi$].[F5] " & _

      "WHERE ([VERi$].[F1]  Is Not Null) and (([KONTROL$E2:E].[F1]) Is Null) and (([KONTROL$F2:F].[F1]) Is Null) and (([KONTROL$G2:G].[F1]) Is Null) " & _

      "ORDER BY Clng([KONTROL$B2:C].[F1]), cdbl([VERi$].[F2])"

---

önce Rütbe sonra Sicil No