Soru Veri girip entere basınca, arka plan rengi değişmesi, girilen tarihleri otomatik sayma.

I

istanbulcahan

Altın Üye
Katılım
11 Ocak 2008
Mesajlar
1,386
Excel Vers. ve Dili
Office 365 (Türkçe)
Altın Üyelik Bitiş Tarihi
12-11-2025
Tc kimlik no yazdıktan sonra entere basınca arka plan rengi istediğim rengi alması, girilen tarihleri otomatik sayması.

Sayfa 1 deki kod
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim son As Long
If Selection.Count > 1 Then Exit Sub
    If Target.Column = 1 And Len(Target.Value) = 11 And Target.Row <> 1 Then
        Target.Interior.ColorIndex = 6
        Target.Offset(0, 3).Value = Date
        son = Range("A" & Rows.Count).End(xlUp).Row
        [F2] = Date
        [G2] = WorksheetFunction.CountIf(Range("D2:D" & son), [F2])
        son = 0
    ElseIf Target.Column = 1 And Target.Row <> 1 And Target.Value = Empty Then
        Target.Interior.ColorIndex = xlNone
        Target.Offset(0, 3).Value = Empty
        Range("G2").Value = Range("G2").Value - 1
    End If
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Olmayan kısım neresi?
ElseIf Target.Column = 1 And Target.Row <> 1 And Target.Value = Empty Then
Bu satırda ne yapmaya çalışıyorsunuz?
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Aşağıdaki kodlar işinizi görüyor mu bir bakın

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Son As Long
Dim Tarih As Range
    If Selection.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Son = Range("A" & Rows.Count).End(xlUp).Row
    If Target.Column = 1 And Len(Target.Value) = 11 And Target.Row <> 1 Then
        Target.Interior.ColorIndex = 6
        Target.Offset(0, 3).Value = Date
        SonF = Range("F" & Rows.Count).End(xlUp).Row
        If SonF < 2 Then SonF = 2
        Set Tarih = Range("F2:F" & SonF).Find(Date)
        If Not Tarih Is Nothing Then
            yaz = Tarih.Row
        Else
            yaz = SonF + 1
            Range("F" & yaz) = Date
        End If
        Range("G" & yaz) = WorksheetFunction.CountIf(Range("D2:D" & Son), Date)
        GoTo Atla
    End If
    If Target.Column = 1 And Target.Row <> 1 And Len(Target) <> 11 Then
        Target.Interior.ColorIndex = xlNone
        If Target.Offset(0, 3).Value <> "" Then
            AraTarih = Target.Offset(0, 3).Value
            SonF = Range("F" & Rows.Count).End(xlUp).Row
            If SonF < 2 Then SonF = 2
            Set Tarih = Range("F2:F" & SonF).Find(AraTarih)
            If Not Tarih Is Nothing Then
                Target.Offset(0, 3).Value = Empty
                Range("G" & Tarih.Row) = WorksheetFunction.CountIf(Range("D2:D" & Son), AraTarih)
                If Range("G" & Tarih.Row) = 0 Then
                    Range("F" & Tarih.Row, "F" & Tarih.Row).Delete Shift:=xlUp
                End If
            End If
        End If
        Target.Activate
    End If
Atla:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
I

istanbulcahan

Altın Üye
Katılım
11 Ocak 2008
Mesajlar
1,386
Excel Vers. ve Dili
Office 365 (Türkçe)
Altın Üyelik Bitiş Tarihi
12-11-2025
ÖmerFaruk' Alıntı:
Aşağıdaki kodlar işinizi görüyor mu bir bakın

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Son As Long
Dim Tarih As Range
    If Selection.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Son = Range("A" & Rows.Count).End(xlUp).Row
    If Target.Column = 1 And Len(Target.Value) = 11 And Target.Row <> 1 Then
        Target.Interior.ColorIndex = 6
        Target.Offset(0, 3).Value = Date
        SonF = Range("F" & Rows.Count).End(xlUp).Row
        If SonF < 2 Then SonF = 2
        Set Tarih = Range("F2:F" & SonF).Find(Date)
        If Not Tarih Is Nothing Then
            yaz = Tarih.Row
        Else
            yaz = SonF + 1
            Range("F" & yaz) = Date
        End If
        Range("G" & yaz) = WorksheetFunction.CountIf(Range("D2:D" & Son), Date)
        GoTo Atla
    End If
    If Target.Column = 1 And Target.Row <> 1 And Len(Target) <> 11 Then
        Target.Interior.ColorIndex = xlNone
        If Target.Offset(0, 3).Value <> "" Then
            AraTarih = Target.Offset(0, 3).Value
            SonF = Range("F" & Rows.Count).End(xlUp).Row
            If SonF < 2 Then SonF = 2
            Set Tarih = Range("F2:F" & SonF).Find(AraTarih)
            If Not Tarih Is Nothing Then
                Target.Offset(0, 3).Value = Empty
                Range("G" & Tarih.Row) = WorksheetFunction.CountIf(Range("D2:D" & Son), AraTarih)
                If Range("G" & Tarih.Row) = 0 Then
                    Range("F" & Tarih.Row, "F" & Tarih.Row).Delete Shift:=xlUp
                End If
            End If
        End If
        Target.Activate
    End If
Atla:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Üstadım. Emeğine sağlık. Kod için. Kodda herhangi bir sorun olmadı. Dosyayı kayıt edip çıkıyorum. Ancak dosyayı tarih ve saat olarak kayıt yaptıgını göremedim. Herhangi bir dizine mi kayıt yapıyor acaba.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Dosya kayıt konusuyla alakalı ben bir şey yapmadım
Sizin mevcut kodlarınıza bakmalısınız.
 
I

istanbulcahan

Altın Üye
Katılım
11 Ocak 2008
Mesajlar
1,386
Excel Vers. ve Dili
Office 365 (Türkçe)
Altın Üyelik Bitiş Tarihi
12-11-2025
Konuyu karıştırmışım. Kusura bakmayın.
 
I

istanbulcahan

Altın Üye
Katılım
11 Ocak 2008
Mesajlar
1,386
Excel Vers. ve Dili
Office 365 (Türkçe)
Altın Üyelik Bitiş Tarihi
12-11-2025
ÖmerFaruk' Alıntı:
Aşağıdaki kodlar işinizi görüyor mu bir bakın

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Son As Long
Dim Tarih As Range
    If Selection.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Son = Range("A" & Rows.Count).End(xlUp).Row
    If Target.Column = 1 And Len(Target.Value) = 11 And Target.Row <> 1 Then
        Target.Interior.ColorIndex = 6
        Target.Offset(0, 3).Value = Date
        SonF = Range("F" & Rows.Count).End(xlUp).Row
        If SonF < 2 Then SonF = 2
        Set Tarih = Range("F2:F" & SonF).Find(Date)
        If Not Tarih Is Nothing Then
            yaz = Tarih.Row
        Else
            yaz = SonF + 1
            Range("F" & yaz) = Date
        End If
        Range("G" & yaz) = WorksheetFunction.CountIf(Range("D2:D" & Son), Date)
        GoTo Atla
    End If
    If Target.Column = 1 And Target.Row <> 1 And Len(Target) <> 11 Then
        Target.Interior.ColorIndex = xlNone
        If Target.Offset(0, 3).Value <> "" Then
            AraTarih = Target.Offset(0, 3).Value
            SonF = Range("F" & Rows.Count).End(xlUp).Row
            If SonF < 2 Then SonF = 2
            Set Tarih = Range("F2:F" & SonF).Find(AraTarih)
            If Not Tarih Is Nothing Then
                Target.Offset(0, 3).Value = Empty
                Range("G" & Tarih.Row) = WorksheetFunction.CountIf(Range("D2:D" & Son), AraTarih)
                If Range("G" & Tarih.Row) = 0 Then
                    Range("F" & Tarih.Row, "F" & Tarih.Row).Delete Shift:=xlUp
                End If
            End If
        End If
        Target.Activate
    End If
Atla:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Üstadım. Kod işimi görmedi.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Kod hangi işinizi görmedi. Ben tarifinizi yanlış mı anlıyorum.
Dosyanızı tekrar denedim.Sorun göremedim.
 

Ekli dosyalar

ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Siz TC numaralarını 8 hane girmişsiniz.
11 hane girin çalışıyor
girdiğiniz tc yi silin çalışıyor.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Gönderdiğiniz son 2 dosyanın birbirinden farkını göremedim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst