yıl artırma

[yalovam77]

merhaba üsdatlarım

ekli belgede anlattım e3:h1000 hücre aralığında tarihler var bir buton olacak ve her tıkladığımda bu hücrelerden yeşil renkli olanlarını bulup sadece yıllarını bir yıl artırabilirmiyiz ilginize teşekkür ederim. iyi günler

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub BUL_YIL_ARTTIR()
    Dim BUL As Range, ADRES As String
    
    Application.FindFormat.Interior.ColorIndex = 4
        
    Set BUL = Range("E:H").Find(What:="", SearchFormat:=True)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            BUL.Value = DateAdd("yyyy", 1, BUL.Value)
            Set BUL = Range("E:H").Find(What:="", After:=BUL, SearchFormat:=True)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[yalovam77]

Çok teşekkür ederim üsdadım. bu şekilde çözüldü. Özür dilerim birde belli bir tarih aralığındakileri yani e1 'e eşit yada büyük ve f1' e eşit yada küçük olanları bir yıl artır şeklinde olabilirmi?

 

[Korhan Ayhan]

Merhaba,

Eğer yine yeşil renkli hücrelerde bu işlemi yapacaksanız aşağıdaki kodu deneyin:

Option Explicit
 
Sub BUL_YIL_ARTTIR()
    Dim BUL As Range, ADRES As String
    
    Application.FindFormat.Interior.ColorIndex = 4
        
    Set BUL = Range("E:H").Find(What:="", SearchFormat:=True)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            If BUL.Value >= Range("E1") And BUL.Value <= Range("F1") Then
                BUL.Value = DateAdd("yyyy", 1, BUL.Value)
            End If
            Set BUL = Range("E:H").Find(What:="", After:=BUL, SearchFormat:=True)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Eğer renkli renksiz tüm hücreleri sorgulamak istiyorsanız aşağıdaki kodu deneyin.

Option Explicit
 
Sub YIL_ARTTIR()
    Dim Veri As Range
    
    For Each Veri In Range("E3:H1000")
        If Veri.Value <> "" Then
            If Veri.Value >= Range("E1") And Veri.Value <= Range("F1") Then
                Veri.Value = DateAdd("yyyy", 1, Veri.Value)
            End If
        End If
    Next
     
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[yalovam77]

Merhaba üsdadım

gönderdiğinzi makroları denedim işime yaradı ancak başka bir konuda daha yardımınızı isteyeceğim.ekte gönderidğim belgederapor aktar butonunun içinde olan aşağıda yazılı kodla sayfadaki verileri kopyalayıp başka sayfaya yapıştırıyorum. ancak tabloda zemin rengi var benim istediğim verileri ve tablo kenarlıklarını zemin rengi olmadan kopyalaıp yapıştırmak istiyorum yardımcı olurmusunuz teşekkür ederim

Private Sub CommandButton3_Click()
Sayfa3.Visible = True
Sayfa3.[A3:x1000].Clear
Sayfa1.Range("a3:x" & Sayfa1.[a1000].End(3).Row).SpecialCells(xlCellTypeVisible).Copy
Sayfa3.[A3].PasteSpecial Paste:=xlPasteValues
Sayfa3.Columns.AutoFit
Sayfa3.[E:H].NumberFormat = "m/d/yyyy"
Sheets("depo").Range("A3:d1000").Copy Sheets("iliste").Range("A5")
Sheets("depo").Range("I3:x1000").Copy Sheets("iliste").Range("E5")
Sayfa3.Select
ActiveWindow.SelectedSheets.Visible = False
End Sub