Yıllık İcmal Almak

(09/05/2021, 12:23)feraz yazdı:

(09/05/2021, 12:06)hayalibey yazdı:

(09/05/2021, 11:43)feraz yazdı:

(09/05/2021, 03:42)hayalibey yazdı: Bu işlemi her yıl 15 Hazirandan sonra dosya ilk açıldığında 1 kere yapması gerekiyor.

Ben kodu çalıştırınca eklettim.O kısmı görmemişim.15 hazirandan sonra sonra kod çalıştırmasını yaparızda 1 defa naıl çalıştırılır onu bilmiyorum.Belki bir sayfa ekleyip bir hücresine 1 kere çalışınca 1 yazdırılıp bir dahaki seneyi bekletilebilinir yoksa zor ihtimal abey bence.Kodu ayarlarsam eklerim bugün.

Hocam aşağıdaki kodu revize etsek
Misal icmal_2 sayfası n1 hücresine 2020 yazsak
Her yıl 15 haziranda açılınca yılı 1 arttırsa

Kod:

Aşağıda bir şeyler yapmaya çalıştım ama takıldım olmadı yani

Visual Basic Code
Private Sub Workbook_Open()
Set vs = ThisWorkbook.Sheets("İCMAL_2")
If Date > DateValue("15/06/" & vs.[N1] + 1) Then vs.[N1] = Year(Date) - 1
If Date >= DateValue("15/06/" & vs.[N1]) And _
Date <= DateValue("14/06/" & vs.[N1] + 1) Then
İşlem Kodları gelse sonrasında vs.[N1] = vs.[N1] + 1
End If
End Sub

O koda gerek kalmadan ayarlayacağım Allah'ın izniyle abey Teşekkür ederim Zafer Hocam

Sub Auto_open()

Dim sonSut As Integer, tar As Range, son As Long

Dim syfYillikicmaL_2 As Worksheet, dolumu As Long



If Day(Date) < 15 Then Exit Sub

If Month(Date) < 5 Then Exit Sub



Set syfYillikicmaL_2 = ThisWorkbook.Sheets("İCMAL_2")

dolumu = 0

With ThisWorkbook.Sheets("YILLIK_İCMAL")

    sonSut = .Cells(1, Columns.Count).End(xlToLeft).Column

    If sonSut < 2 Then Exit Sub

    son = syfYillikicmaL_2.Cells(Rows.Count, 1).End(3).Row

    For Each tar In .Range(.Cells(1, 2), .Cells(1, sonSut))

        If tar.Value = Year(Date) Then

            dolumu = WorksheetFunction.CountA(.Range(.Cells(1, tar.Column), .Cells(Rows.Count, tar.Column)))

            If dolumu > 1 Then GoTo var

            syfYillikicmaL_2.Range("A2:A" & son).Copy .Cells(2, 1)

            syfYillikicmaL_2.Range("F2:F" & son).Copy .Cells(2, tar.Column)

            Exit For

        End If

    Next

End With



Application.CutCopyMode = False

Set tar = Nothing: Set syfYillikicmaL_2 = Nothing

MsgBox "Bitti"

var:

Set tar = Nothing: Set syfYillikicmaL_2 = Nothing

End Sub

(09/05/2021, 12:37)feraz yazdı: dolumu As Byte

(09/05/2021, 12:37)feraz yazdı: syfYillikicmaL_2.Range("A2:A" & son).Copy .Cells(2, 1)

(09/05/2021, 16:01)feraz yazdı:

(09/05/2021, 12:37)feraz yazdı: syfYillikicmaL_2.Range("A2:A" & son).Copy .Cells(2, 1)

Abey önceki mesajdaki yukardaki kod gereksiz olmuş onu silin.Çünkü zaten eklemişsiniz.
Ayrıca yıllar otomatik oluşsun derseniz gifi izleyin ve ekteki dosyayı deneyin.
Kod zaten 16/6 dan önce olursa çalışmaz göstermek için böyle yaptım.

[img]https://s3.gifyu.com/images/aaaa6c43e1a612577cef.gif<br />

(09/05/2021, 18:49)hayalibey yazdı: <br />

(09/05/2021, 16:01)feraz yazdı: <br />

(09/05/2021, 12:37)feraz yazdı: <br />syfYillikicmaL_2.Range("A2:A" & son).Copy .Cells(2, 1)<br />

<br />Abey önceki mesajdaki yukardaki kod gereksiz olmuş onu silin.Çünkü zaten eklemişsiniz.<br />Ayrıca yıllar otomatik oluşsun derseniz gifi izleyin ve ekteki dosyayı deneyin.<br />Kod zaten 16/6 dan önce olursa çalışmaz göstermek için böyle yaptım.<br /><br />
Hocam yolladığınız dosya harika çalışıyor ama ben kendi projeme ekleyemed
m bir türlü hata veriyor . Halbuki kopyala modülünü olduğu gibi aldım. Zafer Hocam tam olarak nerede hata yapıyorum
[url=https://gifyu.com/image/5RBu[/url]