süzerek aktarmak

[ramazan_58]

ekteki dosyada yapılan açıklamalar doğrultusunda kod geliştirebilirmisiniz.Şimdden teşekkürler.

 

[ramazan_58]

merhaba

hocam zip formatında gönderiyorum.

 

[ramazan_58]

selamlar

arkadaşlar dosyayı kısaltıp üst yazı sayfasında açıklama yaparak ekledim yardımcı olan arkadaşlara şimdiden teşekkür ederim

 

[ramazan_58]

arkadaşlar bu konuda yardım edebilecek yokmu

 

[ramazan_58]

Merhaba arkadaşlar!!
En son eklenen dosya konusunda yardımcı olan arkadaş olursa çok memnun olurum.Teşekkürler.

 

[ramazan_58]

arkadaşlar ekteki dosyaya bir göz atarmısınız

 

[ramazan_58]

selamlar

arkadaşlar ekteki dosyaya bir göz atarmısınız

 

[ramazan_58]

arkadaşlar ekteki dosyaya göz atarmısınız.

 

[hsayar]

Ben dolaylı yapmıştım çalışma sayfasından sorgulayıp kodu durduruyordum,ama ripek sayesinde kodun içine yerleştridm.
Module1 i aşağıdaki kodlarla değiştiriniz.

Sub VeriSüz1()

Dim a As Variant
Dim b As Variant
Dim c As Variant
Dim d As Variant


'***************************************************

Sheets("ÖZET").Unprotect "1968"
Sheets("ÜST YAZI(1)").Unprotect "1968"
'***************************************************
Sheets("ÜST YAZI(1)").Select
    
     For Each t In Range("g25:g124").Cells
If t.Value = "" Then         'boş hücreleri gösterir
t.EntireRow.Hidden = False
End If
Next t
    
    Range("A25:g124").ClearContents
   'VAR OLAN KISMI TEMİZLER
    
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Interior.ColorIndex = 35
    Range("A24:g24").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    
    '**************************************
    
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
      Range("A25").Select
    End With



'********************************************





Sheets("ÖZET").Select
b = InputBox("Devamsızlık yapan öğrencinin numarasını yazınız.")
a = 2003
If b = "" Then Exit Sub
Range("K2").Select
Selection.AutoFilter Field:=11, Criteria1:=b

'>>>> öğrenci numarasının listede olup olmadığını kontrol eder yoksa işlemi sonlandırır.
If Application.WorksheetFunction.Subtotal(102, [k3:k1000]) = 0 Then
MsgBox b & "  öğrenci numarasına sahip öğrenci bulunamadığından işleminize devam edemiyorum!"
Exit Sub
End If

Range("A3:G" & a).Select
'öğrenci no yok ise  hata vertiyor
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("ÜST YAZI(1)").Select
Range("A25").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'*******************************************************************

   Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With


'***********************************************


Sheets("ÖZET").Select
Selection.AutoFilter Field:=11




Sheets("ÜST YAZI(1)").Select
Range("t25") = b



d = InputBox("Evrakın Numarasını Yazınız.")
Sheets("ÜST YAZI(1)").Select
Range("c6") = d



 '*************************boş hücreleri gizler
 '*************************boş hücreleri gizler
 '*************************boş hücreleri gizler
 
Sheets("ÜST YAZI(1)").Select

For Each t In Range("g25:g122").Cells
If t.Value = "" Then
t.EntireRow.Hidden = True
End If
Next t
    Range("A1").Select
'SATIRLARI GİZLER
 Sheets("ÜST YAZI(1)").Rows("126:65536").EntireRow.Hidden = True
 'SÜTUNLARI GİZLER
 Sheets("ÜST YAZI(1)").Columns("L:ıv").EntireColumn.Hidden = True
      


'****************************************SAYFALARA ŞİFRE KOYAR
Sheets("ÖZET").Protect "1968", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFiltering _
        :=True
ActiveSheet.EnableSelection = xlNoRestrictions
Sheets("ÜST YAZI(1)").Protect "1968", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True



End Sub

 

[ramazan_58]

selamlar

Hocam
If Application.WorksheetFunction.Subtotal(102, [k3:k1000]) = 0 Then
satırında hata veriyor

 

[hsayar]

kodları değiştirdinizmi kendi yazdıklarınızı silip benim yazdıklarımı kopyaladı iseniz hata vermemesi lazım,,, değişiklikten önce orada hata veriyordu bende belirttim zaten onu sonra kontrol koydum.

Dosya ekleyecektim 500 kb sınırı varmış bir şeyler çıkartıp eklerim

eğer ben becerememiş isem hocalarımız yardımlarını esirgemeyecektir.

 

[hsayar]

http://rapidshare.com/files/62962132/Devam_Durumu1_hsr_-_Kopya.xls
buyrun foruma yükleyemedim.

 

[hsayar]

Hata vermemesi lazım tekrar deneyin...

 

[hsayar]

ramazan hocam işinize yarayıp yaramadığınızı söylerseniz sevinirim.

 

[ramazan_58]

Hasan hocam ellerine sağlık yapıp ilgilendin.Teşekkür ediyorum. Kod önceden çalışıyordu.Fakat öğrenci numarası yok ise sayfa parolasını açıp o durumda kalmaya devam ediyordu.Yani üst yazıdaki öğrencinin devam durumunu raporlaştırmıyordu.Gönderdiğin kodlar benim denememle yukarda yazdığım gibi if satırında hata veriyor.Kodu tamamen kopyalayıp yeni bir modül oluşturup ,içine kopyalamama rağmen aynı hatayı vermeye devam etti.Ne yapalım hocam senin canın sağolsun.Önemli olan uğraşmak,bir şeyler öğrenmek hayat boyu devam ededecek olan şeyler bence.Şimdiden ilgine teşekkür ediyorum.iyi çalışmalar diliyorum.
Ramazan

 

[hsayar]

sen tabloyu özet olarak gönderdin herhalde tamamını bir gönder onda bakayım benim indirdiğim dosyaya uyarladığım kısımlar çalışıyor... 99 yani olmayan öğrenci numarasında devam edemiyorum deyip çıkıyor
13 nolu mesajda resim ve ekli dosya var (foruma, rapide dedğil)

 

[ramazan_58]

selamlar

hasan hocam ekteki belgenin 4 . modülü eski çalışan kod yalnızca uyarı vermiyor fakat istenen işlemi yapıyor diğeri hata verdi.

 

[hsayar]

module1 de mesaj gönderip işlemi yapıyor

hocam module4 le module 1 de aktarılan veriler farklı mı ki iki farklı kod kullanıyorsunuz ben fark göremedim

 

[ramazan_58]

Hocam söylediklerinin tamamına katılıyorum acaba benim kullandığım excel sürümündenmi kaynaklınıyor.Bende bir türlü çalışmadı.Ben Office Xp frontpage sürümünü kullanıyorum.

 

[hsayar]

benden bu kadar hocam son bir şey module 1 haricindeki modülleri kaldırın (remove) ve textboxta makroyu modele1 deki süze yönlendirin