Soru Evci İzin (Form Denetimi)

[mesutpeker]

Merhaba 150 kişilik bir pansiyon listesinde evci iznine çıkacak olanların satırın başındaki tik işaretine tıklayarak seçmek ve en sonunda sadece tikli olanların listesini yazdırmak istiyorum. İstediğim öğrenci isminin başındaki tiki işaretlediğimde en sonra evciye çıkacak örneğin 100 kişinin listesini yazdırmak. Yardımcı olursanız çok sevinirim.

https://s2.dosya.tc/server11/sve7gb/Kitap1.xlsx.html

 

[ÖmerBey]

Merhaba,
Örnek dosyanıza Sayfa2 isminde bir sayfa daha ekleyip deneyiniz. Kod listeyi sayfa2'ye oluşturacaktır.

Sub kod()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
x = 1
For Each cb In s1.CheckBoxes
    If cb.Value = 1 Then
        x = x + 1
        sat = cb.TopLeftCell.Row + 1
        For a = 2 To 8
            s2.Cells(x, a - 1) = s1.Cells(sat, a)
        Next
    End If
Next
End Sub

Ancak bu mantıkla hatalar oluşması muhtemeldir. Onay kutusunun aşağı ya da yukarı kayması sonucu farklı kayıtlar listelenebilir. Bence A sütununa onay kutusu koymak yerine belirli bir işaret (mesela "E" harfi) daha mantıklı olur.
Bu mantıktaki dosyanın kodu da aşağıdaki gibi olabilir.

Sub kod2()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
x = 1
For a = 1 To s1.Cells(Rows.Count, "A").End(3).Row
    If s1.Cells(a, "A") = "E" Then
        x = x + 1
        For b = 2 To 8
            s2.Cells(x, b - 1) = s1.Cells(a, b)
        Next
    End If
Next
End Sub

İyi çalışmalar...

 

[tamer42]

Merhaba 150 kişilik bir pansiyon listesinde evci iznine çıkacak olanların satırın başındaki tik işaretine tıklayarak seçmek ve en sonunda sadece tikli olanların listesini yazdırmak istiyorum. İstediğim öğrenci isminin başındaki tiki işaretlediğimde en sonra evciye çıkacak örneğin 100 kişinin listesini yazdırmak. Yardımcı olursanız çok sevinirim.

https://s2.dosya.tc/server11/sve7gb/Kitap1.xlsx.html

Dosyanız linkte,

https://www.dosyaupload.com/johM


seçtiğiniz satırları 2. sayfada ("Print") listeleyecektir, bu sayfayı yazdırabilirsiniz.

umarım işinizi görür.....

 

[mesutpeker]

Dosyanız linkte,

https://www.dosyaupload.com/johM


seçtiğiniz satırları 2. sayfada ("Print") listeleyecektir, bu sayfayı yazdırabilirsiniz.

umarım işinizi görür.....

üstadım eline sağlık ama tarih kısımları print kısmında farklı bir sayı olarak çıkıyor

 

[mesutpeker]

Merhaba,
Örnek dosyanıza Sayfa2 isminde bir sayfa daha ekleyip deneyiniz. Kod listeyi sayfa2'ye oluşturacaktır.

Sub kod()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
x = 1
For Each cb In s1.CheckBoxes
    If cb.Value = 1 Then
        x = x + 1
        sat = cb.TopLeftCell.Row + 1
        For a = 2 To 8
            s2.Cells(x, a - 1) = s1.Cells(sat, a)
        Next
    End If
Next
End Sub

Ancak bu mantıkla hatalar oluşması muhtemeldir. Onay kutusunun aşağı ya da yukarı kayması sonucu farklı kayıtlar listelenebilir. Bence A sütununa onay kutusu koymak yerine belirli bir işaret (mesela "E" harfi) daha mantıklı olur.
Bu mantıktaki dosyanın kodu da aşağıdaki gibi olabilir.

Sub kod2()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
x = 1
For a = 1 To s1.Cells(Rows.Count, "A").End(3).Row
    If s1.Cells(a, "A") = "E" Then
        x = x + 1
        For b = 2 To 8
            s2.Cells(x, b - 1) = s1.Cells(a, b)
        Next
    End If
Next
End Sub

İyi çalışmalar...

bunu nasıl ekleyeceğim üstadım

 

[halit3]

Alternatif kodlar.

Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub Nesneleriekle()

On Error Resume Next
Set s1 = Sheets(ActiveSheet.Name)
For r = 1 To s1.Shapes.Count
If TypeName(s1.Shapes(r).OLEFormat.Object) = "CheckBox" Then
a = MsgBox("Nesneler mevcut yeniden nesneleri oluşturmak istiyorsanız" & Chr(10) & Chr(10) & _
"Nesneleri sil seçeneğine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

sut = "A"
For r = 2 To s1.Cells(Rows.Count, "b").End(3).Row  'kisi_sayisi + 1
If s1.Cells(r, "b").Value <> "" Then
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name

s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(r, sut).Top + 4
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(r, sut).Left + 4
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(r, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 10 's1.Cells(r, sut).Width - 4
s1.Shapes(yer).OLEFormat.Object.Characters.Text = ""
End If
Next r

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "

End Sub

Sub aktar()
Dim Picture As Object
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
For i = 2 To 8
s2.Cells(1, i) = s1.Cells(1, i)
Next i
s2.Range("B2:H" & Rows.Count).ClearContents
sat2 = 2
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn Then
sat1 = Picture.BottomRightCell.Row
For k = 2 To 8
s2.Cells(sat2, k) = s1.Cells(sat1, k)
Next k
sat2 = sat2 + 1
End If
End If
Next Picture
MsgBox "işlem tamam"
End Sub