AccessTr.neTMicrosoft ExcelExcel Cevaplanmış Soruları

Şablonu Belirlenen Sayfalara Kopyalama Yöntemi İle Şartlı Dağıtmak

1 2 3 4 5 6
22/11/2020, 20:49

hayalibey

Sheetschange ve sheetsselectionchange bu kodları silip denedim
sicil sayfaları düzgün

isimler aynı anlayamadım
22/11/2020, 20:51

feraz

(22/11/2020, 20:49)hayalibey yazdı: Sheetschange ve sheetsselectionchange bu kodları silip denedim
sicil sayfaları düzgün

isimler aynı anlayamadım
Son yolladığım dosyada hata var mı?
22/11/2020, 20:52

hayalibey

Hocam onda liste sayfalarına dağıtıyor ama doğru dağıttığını orjinal dosyadan test edemedim
Hocam bağlantı mı kursak
22/11/2020, 20:58

feraz

Kodlar aşağıda.Sub Listele() ve  Sub Siciller() arasındaki farkalr sadece şunlar.

Sub Listele() için
Kod:
Set bul = s2.Range("C:C").Find(s1.Cells(k, i).Value, , , 1)
For i = 16 To 25

Sub Siciller() için
Set bul = s2.Range("B:B").Find(s1.Cells(k, i).Value, , , 1)

For i = 27 To 29


Kod:
Sub Listele()
    Dim s1 As Worksheet, s2 As Worksheet, syfListe As Worksheet
    Dim i As Integer, bul As Range, son As Long, k As Long, say As Long
   
    Set s1 = ThisWorkbook.Sheets("KONTROL")
    Set s2 = ThisWorkbook.Sheets(Me.ComboBox2.Value)
   
    say = 7
    Application.ScreenUpdating = False
    For i = 16 To 25
        son = s1.Cells(Rows.Count, i).End(3).Row
        If son < 2 Then Exit For
        Set syfListe = ThisWorkbook.Sheets(s1.Cells(1, i).Value)
        syfListe.Range("A7:Aj" & Rows.Count).Clear
        syfListe.Range("A1:Z6").UnMerge
        s2.Range("A1:Z6").Copy syfListe.Range("A1")
        Application.CutCopyMode = False
        For k = 2 To son
            Set bul = s2.Range("C:C").Find(s1.Cells(k, i).Value, , , 1)
            If Not bul Is Nothing Then
                s2.Range("A" & bul.Row & ":Aj" & bul.Row).Copy syfListe.Cells(syfListe.Cells(Rows.Count, 1).End(3).Row + 1, 1)
                Application.CutCopyMode = False
            End If
        Next
        Rutbe_Sicil_Sirala2 syfListe.Name
        syfListe.Range("A:E").Columns.AutoFit
    Next
    Application.ScreenUpdating = True

    Set s1 = Nothing: Set s2 = Nothing: Set bul = Nothing: Set syfListe = Nothing

End Sub

Kod:
Sub Siciller()
    Dim s1 As Worksheet, s2 As Worksheet, syfListe As Worksheet
    Dim i As Integer, bul As Range, son As Long, k As Long, say As Long
   
    Set s1 = ThisWorkbook.Sheets("KONTROL")
    Set s2 = ThisWorkbook.Sheets(Me.ComboBox2.Value)
   
    say = 7
    Application.ScreenUpdating = False
    For i = 27 To 29
        son = s1.Cells(Rows.Count, i).End(3).Row
        If son < 2 Then Exit For
        Set syfListe = ThisWorkbook.Sheets(s1.Cells(1, i).Value)
        syfListe.Range("A7:Aj" & Rows.Count).Clear
        syfListe.Range("A1:Z6").UnMerge
        s2.Range("A1:Z6").Copy syfListe.Range("A1")
        Application.CutCopyMode = False
        For k = 2 To son
            Set bul = s2.Range("B:B").Find(s1.Cells(k, i).Value, , , 1)
            If Not bul Is Nothing Then
                s2.Range("A" & bul.Row & ":Aj" & bul.Row).Copy syfListe.Cells(syfListe.Cells(Rows.Count, 1).End(3).Row + 1, 1)
                Application.CutCopyMode = False
            End If
        Next
        Rutbe_Sicil_Sirala2 syfListe.Name
        syfListe.Range("A:E").Columns.AutoFit
    Next
    Application.ScreenUpdating = True
    MsgBox "Bitti."
    Set s1 = Nothing: Set s2 = Nothing: Set bul = Nothing: Set syfListe = Nothing

End Sub

Kod:
Private Sub CommandButton2_Click()
    Listele
    Siciller
End Sub
22/11/2020, 20:59

hayalibey

sizdeki dosyadan kontrol sayfası Pden kopyaladım yine olmadı
22/11/2020, 23:50

hayalibey

Zafer Hocam
liste ve Sicil sayfalarında  isimler ortalanacak time nevs roman 12 punto  olacak imza bilgileri de 12 punto time nevs roman olmalı
Bir de Sicil ve liste sayfalar ıönce A7 den silinmeli baktım şimdi sicil sayfalarında sicil yk ama Sicil 1 2 3 sayfalarında eski veri kalmış onları temizlememiş
Kod baya yavaş çalışıyor  Bilgisayarı donduruyor kod sürekli . dosyayı ekliyorum Hocam
Elinize emeğinize sağlık
1 2 3 4 5 6