otomatik süzme sonucu oluşan değerleri kopyalayıp başka bir sütuna yapıştırmak

[ramazan_58]

Saygıdeğer forum yöneticileri ;
Benim problemim ekte sunduğum kütük adlı çalışma kitabının kütük sayfasında örneğin 1. sınıfı süzdükten sonra birinci sınıfta buluna öğrencilerin numaralarını liste sayfasındaki okul numarası sütununa aktarabilirmiyim.bu konuda yardımcı olursanız sevinirim.
Şimdiden hepinize teşekkür ediyorum.İyi çalışmalar

 

[Recep İpek]

Öncelikle aramıza hoşgeldiniz.

Dosyanızda yaptığım çalışmayı ekte bulabilirsiniz.

Umarım işinize yarar.

 

[ramazan_58]

Selamlar

Öncelikle çok teşekkür ediyorum arkadaşım.Bana yardımcı oldunuz yalnız.Bir problemim daha var.Gönderdiğim excel beşlgesindeki liste ve kütük sayfasına sayfa koruma parolası koyduğum zaman yazılan kod çalışmıyor.
Acaba sayfa korumasında, kilitli olamayan hücrelere kütük sayfasından bilgi aktaracak bir kod varmıdır.Bu konuda yardımcı olabilirseniz çok sevineceğim.
Yardımınız için şimdiden çok teşekkür ediyorum.

 

[Recep İpek]

Sayfa şifrelerinizin Kütük için : ABC , Liste için : ABCD olduğunu düşünürsek aşağıdaki kodları kullanabilirsiniz.

Sub VeriSüz()
On Error GoTo Süz_Hata
Dim a As Variant
Dim b As Variant
Dim c As Variant
Sheets("Kütük").Unprotect "ABC"
Sheets("Liste").Unprotect "ABCD"
Range("a2:a2001").ClearContents
Sheets("Kütük").Select
b = InputBox("Hangi kod numarasınız süzmesini istersiniz?")
a = 999
If b = "" Then Exit Sub
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=3, Criteria1:=b
Range("b2:b" & a).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Liste").Select
Range("a2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Kütük").Select
Selection.AutoFilter
Range("A1").Select
Sheets("Liste").Select
Range("a2").Select
If ActiveCell.Offset(1, 0).Value = "" Then
c = 1
Else
c = ActiveSheet.Range("a65536").End(xlUp).Row - 1
End If
Range("A1").Select
MsgBox b & ".Sınıfda" & Chr(13) & Chr(13) & "Toplam: " & c & " kişi var.", vbCritical + vbDefaultButton1 + vbOKOnly, "BİLGİ"
Sheets("Liste").Select
Range("A1").Select
Süz_Hata:
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
Selection.AutoFilter
Range("A1").Select
Sheets("Liste").Select
Range("A1").Select
MsgBox "Aradığınız Kayıtlar Bulunamadı.", vbCritical + vbDefaultButton1 + vbOKOnly, "RECEP İPEK"
End If
Sheets("Kütük").Protect "ABC", DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Liste").Protect "ABCD", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

 

[ramazan_58]

Selamlar

Canım kardeşim çok teşekkür ediyorum.Şimdi çalıştı.Sağolun var olun.

 

[ramazan_58]

selamlar

Saygıdeğer forum yöneticisi arkadaşım özür dileyerek sizden ufak bir yardım daha istiyorum.Size zahmet.ekteki yardımınızla yapılan kütük belgesindeki liste sayfasının b3 numaralı hücrlesi ile b52 arasına kütük sayfasından süzülen öğrenci numaralarını aktarılmasını istiyorum.yardımınız için şimdiden teşekkür ederim.

 

[ramazan_58]

selamlar

Saygıdeğer arkadaşım bana yardımcı oldunuz teşekkür ederim yalnız bir küçük sorunum daha var.Kütük belgesi içindeki liste sayfasının b3ile b52 hücreleri arasına kütük sayfasından süzülen değerlerin aktarılmasını istiyorum.yardımınız için şimdiden teşekkür ederim.

 

[ramazan_58]

selamlar

selamlar
arkadaşlar ekte sunduğum kütük adlı belgenin kütük sayfasındaki şube ve sınıfa göre süzüp sınıf listelerine aktaracak kolay bir kod yazılabilirmi.bu konuda yardımcı olursanız çok sevinirim.şimdiden yardımınız için çok teşekkür ederim.Ramazansayfada otomatik süzle süzülen bilgileri diğer sayfada belli bir aralığa aktarmak

 

[Recep İpek]

Aşağıdaki kodları kullanabilirsiniz.

Bu kodlara göre düzenlenmiş şekli ektedir.

Sub Güncelle()
On Error Resume Next
Dim sadi As Worksheet
Dim kisi As String
Dim durum As Boolean
Application.ScreenUpdating = False
Set s1 = Sheets("Kütük")
'**************************************************
d = 0
y = 0
For Each sadi In Worksheets
If sadi.Name <> "Kütük" Then sadi.Range("b3:L52").ClearContents
Next
'**************************************************
For i = 2 To s1.[c1001].End(3).Row
durum = False
kisi = s1.Cells(i, "c").Value & s1.Cells(i, "d").Value
    For Each sadi In Worksheets
         If UCase(Left(sadi.Name, 2)) = UCase(kisi) Then
             Set s2 = Sheets(sadi.Name)
             j = s2.[b52].End(3).Row + 1
             If j > 52 Then GoTo Hata:
             s2.Cells(j, "b") = s1.Cells(i, "b")
             s2.Cells(j, "c") = s1.Cells(i, "g")
             s2.Cells(j, "d") = s1.Cells(i, "h")
             s2.Cells(j, "e") = s1.Cells(i, "f")
             s2.Cells(j, "f") = s1.Cells(i, "k")
             s2.Cells(j, "g") = s1.Cells(i, "L")
             s2.Cells(j, "h") = s1.Cells(i, "I")
             s2.Cells(j, "I") = s1.Cells(i, "j")
             s2.Cells(j, "j") = s1.Cells(i, "m")
             s2.Cells(j, "k") = s1.Cells(i, "c")
             s2.Cells(j, "L") = s1.Cells(i, "d")
             d = d + 1
             durum = True
        End If
    Next
    If durum = False Then
Hata:
    Set s2 = Sheets("Hata")
    j = s2.[b52].End(3).Row + 1
             s2.Cells(j, "b") = s1.Cells(i, "b")
             s2.Cells(j, "c") = s1.Cells(i, "g")
             s2.Cells(j, "d") = s1.Cells(i, "h")
             s2.Cells(j, "e") = s1.Cells(i, "f")
             s2.Cells(j, "f") = s1.Cells(i, "k")
             s2.Cells(j, "g") = s1.Cells(i, "L")
             s2.Cells(j, "h") = s1.Cells(i, "I")
             s2.Cells(j, "I") = s1.Cells(i, "j")
             s2.Cells(j, "j") = s1.Cells(i, "m")
             s2.Cells(j, "k") = s1.Cells(i, "c")
             s2.Cells(j, "L") = s1.Cells(i, "d")
    y = y + 1
    durum = True
    End If
Set s2 = Nothing
Next i
'**************************************************
Set s1 = Nothing
Set s2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Bitti." & Chr(13) & Chr(13) & "Aktarılan Öğrenci Sayısı :" & Chr(13) & Chr(13) & "Doğru : " & d & Chr(13) & Chr(13) & "Hatalı  :" & y & Chr(13) & Chr(13) & "Toplam :" & d + y, 64, "UYARI"
[a1].Select
End Sub

 

[ramazan_58]

Selamlar

Hayırlı günler Recep Bey,
Öncelikle zaman ayırıp ilgilendiğiniz için teşekkür ediyorum.
Göndermiş olduğun belgeyi aldım.Gayet güzel çalışıyor yalnız sınıf listelerine bağlı sayfa lar ve formüller olduğundan parola koruması yapmam gerekiyor.Parola koruması olan sayfalarda bu kodu çalıştırmam gerekiyor.Yardım ederseniz sevinirim.Şimdiden çok teşekkür ediyorum.

 

[Recep İpek]

Ekli dosyayı inceleyiniz.

Not:Sayfa isimlerinin ilk iki harfi mutlaka 1A,2A,4B ...vb şeklinde olmalıdır.
3.harften sonrasına istediğinizi yazabilirsiniz.

 

[ramazan_58]

Selamlar

Çok kıymetli üstadım Recep Bey,
Öncelikle zaman ayırıp ilgilendiğin için çok teşekkür ediyorum.Allah böyle çalışkan ve bilgili kişileri milletimizin içinden eksik etmesin.Ben de çalışmayı yeni bir şeyler öğrenmeyi çok seviyorum.Tabi zaman zaman da takıldığım ve çözemediğim şeyler var.Siz değerli hocalarımız sayesinde çözemediğimiz,yapamadığımız şeyleri yapmaya çalışıyoruz.Sağolun var olun.
Göndermiş olduğun belgeyi alıp inceledim.Gayet güzel çalıştığını gördüm.
Bir iki ufak değişiklik yaparak tam istediğim hale dönüştürdüm.Yaptığım bu çalışmayım ekte gönderiyorum.

İşlerinde muvaffakıyetler diler , tüm sevdiğinle mutlu,huzurlu günler geçirmeni temenni ediyorum.

 

[Recep İpek]

Sn.ramazan_58

Çalışmanın size faydalı olmasına çok sevindim.
Sizlere bu şekilde yardımcı olmak, buradan öğrendiklerimizi sizlere paylaşmak bu forumun gerçek amacının bir kanıtıdır.

Çalışmalarınızda başarılar dilerim..

 

[ramazan_58]

Koşullu biçimlendirme ile hücre köşelerine çizgi çekmek

Hocam merhaba iyi günler diliyorum.
hocam ekteki ek ders çalışma kitabının ek ders sayfasındaki
sarı renkli boş hücrelere X değilde hücrenin köşelerinden koşullu
biçimlendirme ile çizgi(kenarlık değil) çizdirmek istiyorum.
Excelin yerleşik işlevleri içinde kenarlık var köşelerden çizgi kısmı
pasif durumda .Pasif olan bu kısmı aktive etmek mümkünmü yoksa kod yazarak böyle bir
şey yapılabilirmi bu konuda yardımcıolabilirmisiniz.
şimdiden teşekkür eder iyi günler dilerim.

ramazan