Sheetschange ve sheetsselectionchange bu kodları silip denedim
sicil sayfaları düzgün
isimler aynı anlayamadım
Şablonu Belirlenen Sayfalara Kopyalama Yöntemi İle Şartlı Dağıtmak
Hocam onda liste sayfalarına dağıtıyor ama doğru dağıttığını orjinal dosyadan test edemedim
Hocam bağlantı mı kursak
Hocam bağlantı mı kursak
Kodlar aşağıda.Sub Listele() ve Sub Siciller() arasındaki farkalr sadece şunlar.
Sub Listele() için
Sub Siciller() için
Sub Listele() için
Kod:
Set bul = s2.Range("C:C").Find(s1.Cells(k, i).Value, , , 1)
For i = 16 To 25Set 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 SubKod:
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 SubKod:
Private Sub CommandButton2_Click()
Listele
Siciller
End Sub
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
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
YILDIZ_TURKOLOG.rar
(Dosya Boyutu: 946,19 KB | İndirme Sayısı: 1)
Konuyu Okuyanlar: 1 Ziyaretçi
