Düşeyara formülünü makroya çevirmek

[herakless07]

Merhaba akadaşlar,
Benim otomatikleştirmeye çalıştığım bir okuma listem var.Listeye tarihler ve sayfalar otomatik ekleniyor.Bazen öğrenciler kitabın tamamını okumadan değiştiriyor bu nedenle sayfa sayısını elle giriyorum o zaman da tabloda formül siliniyor..Ben ekli dosyadaki sayfa sayısı sütunularına sayfa sayılarını başlıktaki formülle değil de makro ile eklemek istiyorum.Bildiğim kadarıyla makro ile eklenirse hem manuel hem de otomatik giriş yapılabiliyor.
İlgilenen arkadaşlara teşekkür ederim, iyi çalışmalar.

 

[herakless07]

herhangi bir çözümü yok mu bu sorunun?

 

[herakless07]

arkadaşlar çözümü varsa siz sadece makro kodunu bir kere yazın ben tüm tablo için çoğaltmaya razıyım.

 

[Korhan Ayhan]

Merhaba,

Bu işlemi yapmak istediğiniz sayfalarda aşağıdai kodu çalıştırıp denermisiniz.

Option Explicit
 
Sub SAYFA_SAYILARI()
    Dim X As Integer, Son As Integer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For X = 3 To 99 Step 4
        With Range(Cells(3, X), Cells(Son, X))
            .FormulaR1C1 = "=IF(RC[-1]="""","""",VLOOKUP(RC[-1],'KİTAP LİSTESi'!C2:C3,2,0))"
            .Value = .Value
        End With
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[herakless07]

Merhaba,

Bu işlemi yapmak istediğiniz sayfalarda aşağıdai kodu çalıştırıp denermisiniz.

Option Explicit
 
Sub SAYFA_SAYILARI()
    Dim X As Integer, Son As Integer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For X = 3 To 99 Step 4
        With Range(Cells(3, X), Cells(Son, X))
            .FormulaR1C1 = "=IF(RC[-1]="""","""",VLOOKUP(RC[-1],'KİTAP LİSTESi'!C2:C3,2,0))"
            .Value = .Value
        End With
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Bey kodu tarih ekleme kodunun altına mı ekleyeceğim çünkü 8-B sayfasının kod bölümünde şu kodlar var

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3:CV36]) Is Nothing Then Exit Sub
If Target.Column = 2 Then Cells(Target.Row, "D") = Date
If Target.Column = 6 Then Cells(Target.Row, "E") = Date
If Target.Column = 6 Then Cells(Target.Row, "H") = Date
If Target.Column = 10 Then Cells(Target.Row, "I") = Date
If Target.Column = 10 Then Cells(Target.Row, "L") = Date
If Target.Column = 14 Then Cells(Target.Row, "M") = Date
If Target.Column = 14 Then Cells(Target.Row, "P") = Date
If Target.Column = 18 Then Cells(Target.Row, "Q") = Date
If Target.Column = 18 Then Cells(Target.Row, "T") = Date
If Target.Column = 22 Then Cells(Target.Row, "U") = Date
If Target.Column = 22 Then Cells(Target.Row, "X") = Date
If Target.Column = 26 Then Cells(Target.Row, "Y") = Date
If Target.Column = 26 Then Cells(Target.Row, "AB") = Date
If Target.Column = 30 Then Cells(Target.Row, "AC") = Date
If Target.Column = 30 Then Cells(Target.Row, "AF") = Date
If Target.Column = 34 Then Cells(Target.Row, "AG") = Date
If Target.Column = 34 Then Cells(Target.Row, "AJ") = Date
If Target.Column = 38 Then Cells(Target.Row, "AK") = Date
If Target.Column = 38 Then Cells(Target.Row, "AN") = Date
If Target.Column = 42 Then Cells(Target.Row, "AO") = Date
If Target.Column = 42 Then Cells(Target.Row, "AR") = Date
If Target.Column = 46 Then Cells(Target.Row, "AS") = Date
If Target.Column = 46 Then Cells(Target.Row, "AV") = Date
If Target.Column = 50 Then Cells(Target.Row, "AW") = Date
If Target.Column = 50 Then Cells(Target.Row, "AZ") = Date
If Target.Column = 54 Then Cells(Target.Row, "BA") = Date
If Target.Column = 54 Then Cells(Target.Row, "BD") = Date
If Target.Column = 58 Then Cells(Target.Row, "BE") = Date
If Target.Column = 58 Then Cells(Target.Row, "BH") = Date
If Target.Column = 62 Then Cells(Target.Row, "BI") = Date
If Target.Column = 62 Then Cells(Target.Row, "BL") = Date
If Target.Column = 66 Then Cells(Target.Row, "BM") = Date
If Target.Column = 66 Then Cells(Target.Row, "BP") = Date
If Target.Column = 70 Then Cells(Target.Row, "BQ") = Date
If Target.Column = 70 Then Cells(Target.Row, "BT") = Date
If Target.Column = 74 Then Cells(Target.Row, "BU") = Date
If Target.Column = 74 Then Cells(Target.Row, "BX") = Date
If Target.Column = 78 Then Cells(Target.Row, "BY") = Date
If Target.Column = 78 Then Cells(Target.Row, "CB") = Date
If Target.Column = 82 Then Cells(Target.Row, "CC") = Date
If Target.Column = 82 Then Cells(Target.Row, "CF") = Date
If Target.Column = 86 Then Cells(Target.Row, "CG") = Date
If Target.Column = 86 Then Cells(Target.Row, "CJ") = Date
If Target.Column = 90 Then Cells(Target.Row, "CK") = Date
If Target.Column = 90 Then Cells(Target.Row, "CN") = Date
If Target.Column = 94 Then Cells(Target.Row, "CO") = Date
If Target.Column = 94 Then Cells(Target.Row, "CR") = Date
If Target.Column = 98 Then Cells(Target.Row, "CS") = Date
If Target.Column = 98 Then Cells(Target.Row, "CV") = Date
End Sub

 

[Korhan Ayhan]

Merhaba,

İsterseniz kullanmak istediğiniz sayfalarınıza buton ekleyin ve kodu butona atayın.

İsteseniz sayfalarınızın aktif olma olayına yazın. Sayfayı tıkladığınızda kod otomatik çalışsın.

Sayfaların aktif olma durumu için üstteki önerdiğim kodu boş bir modüle uygulayın. Daha sonra aşağıdaki kodu hangi sayfalarda bu işlem olacak o sayfaların kod bölümüne ekleyin.

Private Sub Worksheet_Activate()
    SAYFA_SAYILARI
End Sub

 

[herakless07]

Önerdiklerinizi uygulayınca
Compile error:
Expected End Sub

hatası aldım.
kodu önce yeni bir modüle kopyalayıp kaydettim.Sonra 8-C sayfası kod bölümüne

Private Sub Worksheet_Activate()
SAYFA_SAYILARI
End Sub kodunu kopyaladım.

 

[Korhan Ayhan]

Merhaba,

Hatalı uygulama yapmışsınız demektir. Tekrar dikkatlice uygulayınız.

 

[herakless07]

Korhan bey rica etsem söylediklerinizi uygulayıp dosyayı ekler misiniz? Bir türlü yapamadım

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı inceleyiniz.

Sayfalara buton ekledim. İsterseniz butona tıklayıpta kodu çalıştırabilirsiniz.

Eğer sayfaların aktif olma durumundaki kod sizi rahatsız ederse sayfaların kod bölümündeki kodları aşağıdaki şekilde pasif duruma getirebilirsiniz.

Private Sub Worksheet_Activate()
    [COLOR=red]'[/COLOR][COLOR=black]SAYFA[/COLOR]_SAYILARI
End Sub

 

[herakless07]

Çok teşekkür ederim.İyi çalışmalar