• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

liste oluşturma

Katılım
5 Mart 2008
Mesajlar
896
Excel Vers. ve Dili
EV:EXCEL 2010-TÜRKÇE
İŞ:EXCEL 2010-TÜRKÇE
arkadaşlar ekteki dosyada tık işareti olan öğrencileri numarası adı soyadı ve sınıfı şeklinde başka bir sayfada nasıl listelerim?Yalnız liste bayağı uzun ben sadece bir kısmını ekledim.
 

Ekli dosyalar

arkadaşlar ekteki dosyada tık işareti olan öğrencileri numarası adı soyadı ve sınıfı şeklinde başka bir sayfada nasıl listelerim?Yalnız liste bayağı uzun ben sadece bir kısmını ekledim.

Bu nesnelerle işlem yapmak oldukça zor ve zahmetli işler neden diyecekseniz bu nesneler öncelikle hücrelerden taşmamalı sizin eklediğiniz nesneler hücrelerden taşmış dolayısıyla yazılacak kodlar hic doğru sonuç vermeyecektir.

Burada yapılması gereken en doğru yol nesneleri silmek ve nesneleri de kod ile oluşturmak gerekir.

Makroları bir modüle ekleyin ve çalıştırın. makrolar üzerinde yazan işlemleri yapıyor.

kod:

Kod:
Sub nesne_ekle()

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 düğmesine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

sut = "c"
say = 2

For r = 3 To s1.Cells(Rows.Count, "B").End(3).Row
say = say + 1
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name

s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(say, sut).Top + 4
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(say, sut).Left
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(say, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 12
s1.Shapes(yer).OLEFormat.Object.Characters.Text = s1.Cells(r, "B").Value
s1.Shapes(yer).OLEFormat.Object.Name = "B" & r - 2

Next r

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


Sub nesne_sil()
Dim Picture As Object
On Error Resume Next
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "HTMLCheckbox" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
End If
Next Picture
End Sub


Sub hepsini_sec()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
Next Picture
End Sub

Sub hepsini_kaldır()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
End Sub

Sub Secilenleri_aktar()
Sheets("Sayfa2").Range("A3:C500").ClearContents
sat1 = 3
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = 3 Then
If s1.Shapes(Picture.Name).OLEFormat.Object = 1 Then
sat2 = Picture.BottomRightCell.Row
Worksheets("Sayfa2").Cells(sat1, 1).Value = Worksheets("Sayfa1").Cells(sat2, 1).Value
Worksheets("Sayfa2").Cells(sat1, 2).Value = Worksheets("Sayfa1").Cells(sat2, 2).Value
Worksheets("Sayfa2").Cells(sat1, 3).Value = Worksheets("Sayfa1").Cells(sat2, 4).Value
sat1 = sat1 + 1
End If
End If
End If
Next Picture
End Sub
 
Bu nesnelerle işlem yapmak oldukça zor ve zahmetli işler neden diyecekseniz bu nesneler öncelikle hücrelerden taşmamalı sizin eklediğiniz nesneler hücrelerden taşmış dolayısıyla yazılacak kodlar hic doğru sonuç vermeyecektir.

Burada yapılması gereken en doğru yol nesneleri silmek ve nesneleri de kod ile oluşturmak gerekir.

Makroları bir modüle ekleyin ve çalıştırın. makrolar üzerinde yazan işlemleri yapıyor.

kod:

Kod:
Sub nesne_ekle()

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 düğmesine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

sut = "c"
say = 2

For r = 3 To s1.Cells(Rows.Count, "B").End(3).Row
say = say + 1
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name

s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(say, sut).Top + 4
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(say, sut).Left
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(say, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 12
s1.Shapes(yer).OLEFormat.Object.Characters.Text = s1.Cells(r, "B").Value
s1.Shapes(yer).OLEFormat.Object.Name = "B" & r - 2

Next r

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

Sub nesne_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Or TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
Next Picture
End Sub



Sub hepsini_sec()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
Next Picture
End Sub

Sub hepsini_kaldır()
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
End Sub

Sub Secilenleri_aktar()
Sheets("Sayfa2").Range("A3:C500").ClearContents
sat1 = 3
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = 3 Then
If s1.Shapes(Picture.Name).OLEFormat.Object = 1 Then
sat2 = Picture.BottomRightCell.Row
Worksheets("Sayfa2").Cells(sat1, 1).Value = Worksheets("Sayfa1").Cells(sat2, 1).Value
Worksheets("Sayfa2").Cells(sat1, 2).Value = Worksheets("Sayfa1").Cells(sat2, 2).Value
Worksheets("Sayfa2").Cells(sat1, 3).Value = Worksheets("Sayfa1").Cells(sat2, 4).Value
sat1 = sat1 + 1
End If
End If
End If
Next Picture
End Sub

üstad ilginize teşekkür ederim fakat makroları çalıştıramadım.
 
üstad ilginize teşekkür ederim fakat makroları çalıştıramadım.

Dört nolu mesajımda aynen şöyle yazmıştım.
Makroları bir modüle ekleyin ve çalıştırın. makrolar üzerinde yazan işlemleri yapıyor.

Bu işlemi yaptınızmı?

Mesajınız 780 den fazla olmuş makroyu neden çalıştıramadığınızı anlayamadım bir hata mı aldınız yoksa sakın ben makroları çalıştırmayı bilmiyorum demeyin inanmam.
 
Üstad dediklerinizi aynen yaptim ama butona bastigimda herhangi bir işlem yapmadi hata da vermedi sadece nesne ekle makrosu calisti.
 
Üstad dediklerinizi aynen yaptim ama butona bastigimda herhangi bir işlem yapmadi hata da vermedi sadece nesne ekle makrosu calisti.

Kodları eklediğiniz dosya ile ilgili yaptığınız işlemlere ait yeni dosyanızı bir ekleyinde bakalım hata neredeymiş.
 
herhalde excelin sürümünden kaynaklanıyor bazı nesneleri ofis2003 de siliyor ofis 2007 de silmiyor.
sil makrosunu bu kod ile değiştir.


Kod:
Sub nesne_sil()
Dim Picture As Object
On Error Resume Next
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "HTMLCheckbox" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
End If
Next Picture
End Sub

yukarıdaki mesajdaki sil makrosunu ben değiştirdim.
 

Dosyada 5 adet makro var
siz sadece iki tanesine komut düğme eklemişsiniz.

diğerlerinede komut düğmesi ekleyin
ve sonrada işlem sırasına göre makroları çalıştırın.

1-nesne_sil
2-nesne_ekle
3 a-hepsini_sec
3 b-hepsini_kaldır
4-Secilenleri_aktar
 
polis-53 adlı kullanıcı söylediklerimi aynen yapmış
 
üstadlar dediklerinizi yaptım fakat yeni öğrenciler ekleyince olmadı.kopyala yapıştır yaptım olmadı.kopyala yapıştır yapınca nesneler kayboluyor.tüm listeyi ekledim.sayfa adlarına göre liste oluşturulacak.
 

Ekli dosyalar

üstadlar dediklerinizi yaptım fakat yeni öğrenciler ekleyince olmadı.kopyala yapıştır yaptım olmadı.kopyala yapıştır yapınca nesneler kayboluyor.tüm listeyi ekledim.sayfa adlarına göre liste oluşturulacak.


Bu konu başlığı altında sizin sorunuza cevap veren üç kişi var sorunuzu alıntı yaparak sorunuz.
Eğer sorunuz bana ise 788 mesajınız etmiş dediklerimizi yaptığını söylüyorsun hayır dediklerimi yapmamışsınız.

Söylediklerimi (polis-53) üye yapmış o dosyada kodlar çalışıyor
eklemiş olduğunuz dosyaların uzantısı xlsx bu uzantılı dosyalarda makroların çalışmayacağını 788 mesajı olan bir kişinin bilmesi gerekir diye düşünüyorum.

(polis-53) 'ün eklediği dosyaya verilerinizi kopyalayın yapıştırın çalıştığını göreceksiniz.
 
Bu konu başlığı altında sizin sorunuza cevap veren üç kişi var sorunuzu alıntı yaparak sorunuz.
Eğer sorunuz bana ise 788 mesajınız etmiş dediklerimizi yaptığını söylüyorsun hayır dediklerimi yapmamışsınız.

Söylediklerimi (polis-53) üye yapmış o dosyada kodlar çalışıyor
eklemiş olduğunuz dosyaların uzantısı xlsx bu uzantılı dosyalarda makroların çalışmayacağını 788 mesajı olan bir kişinin bilmesi gerekir diye düşünüyorum.

(polis-53) 'ün eklediği dosyaya verilerinizi kopyalayın yapıştırın çalıştığını göreceksiniz.

üstad polis-53 ün yaptığı dosyaya verileri yapıştırıyorum fakat eski checkboxlar değişmiyor aynen kalıyor.özel yapıştır dediğimde de checkboxlar kopyaladığım şekliyle olmuyor.
 
16 nolu mesajdaki eklediğim dosyadan bir tanesini kopyala yapıştır yaparak sonucu sizde görebilir siniz halit3 üstadım.
 
1,12,16 nolu mesajlardaki seçenek nesneleri her üç dosyada da farklı nesneler var.
sil komutu aşağıdaki gibi olacak.
kod:

Kod:
Sub nesne_sil()
Dim Picture As Object
On Error Resume Next
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "HTMLCheckbox" Or _
TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
End If
Next Picture
End Sub

aşağıdaki linkdeki görsel videoyu irdeleyiniz.

görsel video

video gükleniyor ara ara deneyiniz.
 
Geri
Üst