Evrak takipte günü geçenleri arşive aktarma

[ASLAN7410]

Merhaba arkadaşlar, herkese hayırlı sabahlar.

Forumdaki arkadaşların yardımı ile takip ettiğim evraklar için, evrak takip sayfası hazırladım.

Benim istediğim sayfayı açtığımda, günü geçmiş evrakları otomatik olarak ARŞİV sayfasına aktarmak istiyorum.

Takip ettiğim evrak fazla olduğu için bunu kopyala yapıştır ile yaptığım zaman uğraştırıyor.

Yardım edecek arkadaşlara şimdiden teşekkür ediyorum.

http://s3.dosya.tc/server7/jkyuwl/Yeni_klasor.rar.html

 

[vardar07]

Arşiv sayfası kod bölümüne ekleyin.

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Set s1 = Sheets("EVRAK")
Set s2 = Sheets("ARŞİV")
son = s1.Range("B" & Rows.Count).End(3).Row
a = 2
For i = 2 To son
son1 = s2.Range("B" & Rows.Count).End(3).Row + 1
If CDate(s1.Cells(i, "H")) < Date Then
s2.Cells(son1, 1) = WorksheetFunction.Max(s2.Range("A2:A" & son1)) + 1
For k = 2 To Range("b1").End(2).Column
s2.Cells(son1, k) = s1.Cells(i, k)
Next k
s1.Range("A" & i & ":J" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub

 

[ASLAN7410]

Sayın Vardar Bey ilginiz için çok teşekkür ediyorum, ellerinize sağlık.

Sizin dediğiniz gibi yaptım, C sütunundaki aynı şahıslara ait evrakların sadece 1 tanesini aktarıyor ve EVRAK sayfasında günü geçmiş evrak bilgilerinin hepsi duruyor.

Benim istediğim EVRAK isimli sayfadaki günü geçmiş evrakların hepsini ARŞİV sayfasına aktarması ve EVRAK sayfasında bu bilgilerin silinmesini istiyorum.

 

[vardar07]

Sadece bir tanesi değil günü geçmişleri aktarıyor. Tarihleri değiştirerek deneyiniz.
Yukardaki mesajda kodlar yenilenmiştir.

 

[acolkesen1]

Merhaba,
Sayın vardar07 nin çözümüne alternatif olarak aşağıdaki kod ile tarihi geçmiş satırları arşiv sayfasına kopyalayabilirsiniz. Kodu bir butona atayabilir veya auto_open altına yazabilirsiniz.
For i = 2 To [evrak!b65536].End(3).Row
If sheets("evrak").Cells(i, "h") < Date Then Rows(i).Copy [arşiv!a65536].End(3).Offset(1, 0)
Next
İyi çalışmalar.

 

[ASLAN7410]

Sayın Vardar Bey tam istediğim gibi oldu, ellerinize sağlık, çok teşekkür ediyorum.
Hayırlı çalışmalar.

 

[ASLAN7410]

Sayın acolkesen1 sizinde ilginize çok teşekkür ederim, sizin kodlar çok kısa ve güzel çalışıyor, fakat EVRAK sayfasındaki günü geçenlerininde silinmesini istiyorum.

Ayrıca kopyalama yaptığında sayfadaki renkleri ile birlikte atıyor, sadece değerleri atabilir mi?

 

[acolkesen1]

Merhaba,
kodun başına aşağıdaki satırı ilave ediniz.
sheets("arşiv").range("a2: j" & [a65536].end(3).row).clearcontents
Esenkalın.

 

[acolkesen1]

Tekrar merhaba,
İŞ yoğunluğundan aceleyle sorunuzu hem yanlış anlamışım hem de eksik okumuşum. Kusura bakmayın. Kodu aşağıdaki ile değiştirirseniz günü geçenleri evrak sayfasından siler. İlave ettiğimiz ilk satır ise Arşiv sayfasını her aktarmadan önce temizler.

If [arşiv!a2] <> "" Then Sheets("arşiv").Range("a2: j" & [arşiv!a65536].End(3).Row).ClearContents
For i = [evrak!b65536].End(3).Row To 1 Step -1
If Sheets("evrak").Cells(i, "h") < Date Then
Rows(i).Copy
[arşiv!a65536].End(3).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows(i).Delete xlUp
End If

Next

 

[ASLAN7410]

Sayın acolkesen1 kodlar çok güzel çalışıyor ancak, ARŞİV sayfasını tümünü temizliyor.

Benim istediğim günü geçenleri ARŞİV sayfasına depo yapmaktı.

 

[acolkesen1]

Merhaba,
9 nolu mesajda belirttiğim gibi kırmızı ilk satır arşiv sayfasını temizler. Arşivdekilerin silinmesini istemiyorsanız o satırı kaldırarak kodu çalıştırın.

 

[Ömer BARAN]

Merhaba Sayın ERASLAN.

Dosyanızdaki kodların çalışma sıraları/düzeni biraz karışık geldi bana ama maksatı bilemeyince bu konuda öneride bulunmak zor.
Bence EVRAK sayfasına ait Selection_Change ve Activate kodlarını yerinde ve gerekirse kapsam daraltarak kullanmakta yarar var, örneğin sadece J sütununda değişiklik olduğunda veya yeni kayıt eklerken B-J sütun aralığında hiç boş hücre kalmamışsa, yani gerekli tüm alanlar doldurulmuşsa diye koşula bağlı sıra numarası verme kodu tetiklenebilir, sadece H sütununa veri girildiğinde J sütunundaki hesaplama yaptırılabilir gibi.
Kanaatim o ki; herbir işlemi ayrı kod halinde kaydedip, hangi koşulda hangi kodun çalışması gerekiyorsa o kod'u tetiklemek daha doğru bir yaklaşım olacaktır.

ARŞİV sayfasına aktarma işlemi ile ilgili olarak; EVRAK sayfasının kod bölümüne;
Mavi satırlar ARŞİV sayfanızdaki sıra numaralarını düzeltiyor, gereksizse silin.

[COLOR="Red"][FONT="Trebuchet MS"]Private Sub Worksheet_Activate()[/COLOR]
For satır = [H65536].End(3).Row To 2 Step -1
    If Cells(satır, 8) = "" Or Cells(satır, 8) >= Date Then GoTo 10
    sat = Sheets("ARŞİV").[H65536].End(3).Row + 1
    Range("A" & satır & ":J" & satır).Copy Sheets("ARŞİV").Range("A" & sat & ":J" & sat)
    Sheets("ARŞİV").Range("A" & sat & ":J" & sat).FormatConditions.Delete
    Sheets("ARŞİV").Range("A1:J" & Sheets("ARŞİV").[H65536].End(3).Row).Borders.LineStyle = xlContinuous
    Range("A" & satır & ":J" & satır).Delete Shift:=xlUp
10: Next
[COLOR="Blue"]With Sheets("ARŞİV").Range("A2:A" & Sheets("ARŞİV").[H65536].End(3).Row)
    .Formula = "=Row()-1"
    .Value = .Value
End With[/COLOR]
    Call sayıverme
[COLOR="red"]End Sub[/FONT][/COLOR]

Ayrıca belgenizde oldukça karmaşık olan gün hesabına ilişkin J sütunundaki formüllerden kurtulmak için ise sayıverme kodlarında en sondaki
Application.ScreenUpdating = True
satırından önce aşağıdaki satırları ekleyebilirsiniz. Böylece belgedeki formül yoğunluğunu azalacaktır.
Benzer şey C sütunundaki formül için de düşünülmeli bence.

[FONT="Trebuchet MS"]With Range("J2:J" & [H65365].End(3).Row)
    .Formula = "=TRIM(IF(H2=TODAY(),""Evrakı bugün yap"","""")" & _
                "&IF(DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""y"")=0,"""","" ""&DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""y"")&"" yıl"")" & _
                "&IF(DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""ym"")=0,"""","" ""&DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""ym"")&"" ay"")" & _
                "&IF(DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""md"")=0,"""","" ""&DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""md"")&"" gün"")" & _
                "&IF(H2>TODAY(),"" kaldı"",IF(H2<TODAY(),"" geçti"","""")))"
    .Value = .Value
End With[/FONT]

 

[ASLAN7410]

Merhaba arkadaşlar hayırlı geceler.
Vardiyalı çalıştığım için bilgisayar başına yeni geçtim.

Sayın acolkesen1 ilginiz için çok teşekkür ediyorum, hayırlı geceler.

Sayın Ömer Bey sizin ilginizide çok teşekkür ediyorum.

Ömer Bey önerileriniz çok süper oldu, formülleri sizin dediğiniz gibi yaptım, ancak sadece EVRAK sayfasında B sütunu için 2 tane makro ve H sütununa göre 1 tane makro çalıştırmasını yapamadım.

 

[Ömer BARAN]

Nedir sorun acaba?
Şu anki haliyle J sütununun dolu olduğu satıra kadar çalışan ve
H sütunundaki tarihe göre hesaplama yapan bir formül var,
zaten orijinal formülünüz de A ve B sütununa bağlı değildi.
Tam olarak açıklar mısınız?

 

[ASLAN7410]

Sayın Ömer Bey çözümleriniz süper ve kolay anlaşılır, çok teşekkür ediyorum. Kod yazmaktan anlamadığım için forumda bulduğum örnekleri kendime aldığımdan ancak bu şekilde yapabilmiştim.

Sizin hazırlamış olduğunuz kodlarla aşağıdaki gibi sayfamdaki kodları düzelttim.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Evrak sayfasındaki yukarıdaki Worksheet_SelectionChange koduna göre aşağıdaki kodların B sütununa göre SayıVer ve PersonelBul kodları, J sütununa görede TarihDüzelt kodları çalışmasını istiyorum.


B sütununa göre aşağıdaki kod çalışsın.

Sub SayıVer()
With Sheets(1).Range("A2:A" & Sheets(1).[B65536].End(3).Row)
    .Formula = "=Row()-1"
    .Value = .Value
End With
End Sub

Sub PersonelBul()
With Range("C2:C" & [B65365].End(3).Row)
    .Formula = "=IF(RC[-1]="""","""",IFERROR(VLOOKUP(RC[-1],'PERSONEL LİSTESİ'!R2C2:R5000C3,2,0),""Aradığınız kişi yok""))"
    .Value = .Value
End With
End Sub

J sütununa göre aşağıdaki kod çalışsın.

Sub TarihDüzelt()
With Range("J2:J" & [H65365].End(3).Row)
    .Formula = "=TRIM(IF(H2=TODAY(),""Evrakı bugün yap"","""")" & _
                "&IF(DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""y"")=0,"""","" ""&DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""y"")&"" yıl"")" & _
                "&IF(DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""ym"")=0,"""","" ""&DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""ym"")&"" ay"")" & _
                "&IF(DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""md"")=0,"""","" ""&DATEDIF(MIN(H2,TODAY()),MAX(H2,TODAY()),""md"")&"" gün"")" & _
                "&IF(H2>TODAY(),"" kaldı"",IF(H2<TODAY(),"" geçti"","""")))"
    .Value = .Value
End With
End Sub

Aşağıdaki gibi yapınca sayfanın hangi hücresine tıklarsam hepsinde çalışıyor, işlem yavaşlıyor.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
     SayıVer
     PersonelBul
     TarihDüzelt
End Sub

 

[Ömer BARAN]

Önceki cevabımda belirttiğim şey de tam olarak buydu.
Change kodlarına mümkün olduğunca başvurmamak, ille de gerekiyorsa,
aktef hücrenin satırı şuysa/seçili hücrenin sütunu şuysa işlem yap/yapma gibi koşullar ekleyerek
işlemin kapsamını daraltmak gerekir diye düşünüyorum.
Formüllerin sadece son dolu satırda çalışması yeterli olmaz mı?
O zaman sicil yazıldığında personel bulma, tarih yazıldığında da .. gün geçti/kaldı formülünün çalışması yeterli değil mi? Yani ilk satırdan son satıra kadar formül uygulamak şart değil doğru mudur?
Eğer durum böyleyse formül kodlarını Worksheet_Selection_Change olarak değil Worksheet_Change olayıyla ilişkilendirmek gerekir.

 

[ASLAN7410]

Sayın Ömer Bey aşağıdaki gibi yapmaya çalıştım ancak bu seferde Case 2: PersonelBul çalışmadı.

PersonelBul kodunu Case2: SayıVer , PersonelBul şeklinde yazdım hata verdi.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Select Case Target.Column
        Case 2: SayıVer
        Case 2: PersonelBul
        Case 8: TarihDüzelt
    End Select
End Sub

 

[ASLAN7410]

Sayın Ömer Bey sorumu yazıp gönderdiğimde cevabınızı gördüm, kusura bakmayın.

Dediğiniz doğru, aşağıdaki kodu düzenleyebilir misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Column
        Case 2: SayıVer
        Case 2: PersonelBul
        Case 8: TarihDüzelt
    End Select
End Sub

 

[ASLAN7410]

Sayın Ömer Bey aşağıdaki gibi yaptım, 3.makro olan TarihDüzelt makrosu çalışmadı.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B5000")) Is Nothing Then Exit Sub
    Call SayıVer
    Call PersonelBul
If Intersect(Target, Range("H2:H5000")) Is Nothing Then Exit Sub
    Call TarihDüzelt
End Sub

 

[vardar07]

Deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B5000", "H2:H5000")) Is Nothing Then Exit Sub
 If Target.Column = 2 Then
 Call SayıVer
 Call PersonelBul
End If
 If Target.Column = 8 Then
   Call TarihDüzelt
End If
End Sub