QR Sayaç

[leonadies]

Üstadlar Merhaba;

Excel dosyasının GİRİŞ A1 hücresinde barkod okuyucu ile Kod okutuyorum. B1 hücreside "KAYDET,SİL" (veri doğrulama) değerlerine sahip. Okuttuğum değerleride KAYIT Sekmesine atmasını bekliyorum.
Bunu yaparkende makrodan isteğim öncelikle KAYIT sekmesi A:A sütununda o kod var mı baksın.Yoksa o sütuna kendisini yazsın. Devamında B:B sekmesinde de kaç adet okutuluyorsa bu sütunda bunu işlesin. Bu işlemi yaparken Giriş Sekmesindeki "KAYDET,SİL" durumunu dikkate alsın. Yani kaydet seçili ise kaydedecek ve sayaç artacak, SİL seçili ise sayaçtan düşürecek.

Ben bu isteğimi Eğersay formül yardımı ile ayağa kaldırdım ancak çok fazla veri girişi olduğunda sütun dolacak excel şişecek diye çok ikna edemedim kendimi. Bu method yapılabilirse sanırım daha yerinde olacak. Dosyalarım ekte

 

[Muzaffer Ali]

Merhaba.

Giriş adlı sayfanın kod sayfasına aşağıdaki kodları kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    Dim SonSatir As Long
    Dim EkleSil As Integer
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        If Range("B1") = "KAYDET" Then
            EkleSil = 1
        ElseIf Range("B1") = "SİL" Then
            EkleSil = -1
        End If
        With Worksheets("Kayıt")
            Set Bul = .Range("A:A").Find(what:=Range("A1").Text, LookAt:=xlWhole)
            If Bul Is Nothing Then
                If Range("B1") = "SİL" Then
                    MsgBox "Barkod kayıtlı değil, silinemiyor."
                    Exit Sub
                End If
                SonSatir = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                .Range("A" & SonSatir) = Range("A1")
                .Range("B" & SonSatir) = 1
            Else
                If Range("B1") = "SİL" And .Range("B" & Bul.Row) = 0 Then
                    MsgBox "Bu barkodun sayacı sıfırdır, silinemiyor."
                    Exit Sub
                End If
                .Range("B" & Bul.Row) = .Range("B" & Bul.Row) + EkleSil
            End If
        End With
    End If
End Sub

 

[leonadies]

@dalgalikur Ellerinize sağlık muhteşem olmuş gerçekten Çok teşekkür ediyorum

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[leonadies]

@dalgalikur Hocam KAYIT sekmesine verileri işlerken C:C sütununa okutulduğu günün tarihini işleyebilir miyiz? Tabi bu sütuna makroda tarih at diyeceksiniz ama her seferinde o kayıtlı eski tarihleri nasıl koruyacağız pek akıl yürütemiyorum. Çözümü var mı?
Not:Aynı fiş Pazartesi kaydedilip cuma tekrar son kez okutulunca (kaydet veya sil) kendisini Cuma gününe güncellemesinde sorun yok.

 

[Muzaffer Ali]

Tam anlayamadım. İlk kayıt edildiği tarih ile son değişiklik olduğu tarihi mi saklamak istiyorsunuz.
Not:Hücre açıklaması olarak her değişiklik tarihi saklanabilir.
Aşağıdaki kodları deneyin. B sütununa açıklama ekler.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    Dim SonSatir As Long
    Dim EkleSil As Integer
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        If Range("B1") = "KAYDET" Then
            EkleSil = 1
        ElseIf Range("B1") = "SİL" Then
            EkleSil = -1
        End If
        With Worksheets("Kayıt")
            Set Bul = .Range("A:A").Find(what:=Range("A1").Text, LookAt:=xlWhole)
            If Bul Is Nothing Then
                If Range("B1") = "SİL" Then
                    MsgBox "Barkod kayıtlı değil, silinemiyor."
                    Exit Sub
                End If
                SonSatir = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                .Range("A" & SonSatir) = Range("A1")
                .Range("B" & SonSatir) = 1
                .Range("B" & SonSatir).AddComment
                .Range("B" & SonSatir).Comment.Text "Kayıt Tarihi: " & Now
            Else
                If Range("B1") = "SİL" And .Range("B" & Bul.Row) = 0 Then
                    MsgBox "Bu barkodun sayacı sıfırdır, silinemiyor."
                    Exit Sub
                End If
                .Range("B" & Bul.Row) = .Range("B" & Bul.Row) + EkleSil
                .Range("B" & Bul.Row).Comment.Text .Range("B" & Bul.Row).Comment.Text & Chr(10) & "Değişiklik Tarihi: " & Now
            End If
        End With
    End If
End Sub

 

[leonadies]

@dalgalikur Hocam açıklama şeklinde değilde direk C:C sütuna eklerse süper olur. Demek istediğim ise;
Örneğin;
FİŞ NO 155 21.04.2020 kaydettim.
FİŞ NO 255 25.04.2020 kaydettim.
C:C sütununda makro çalışınca Fiş NO 155 in kayıt tarihinide 25.04.2020 olarak günceller endişesi. Yani eski tarihi koruma çabası. He fiş numarası 155 daha sonraki günlerde yeniden işlem görür ozaman tarihi o güne güncellenir o önemli değil

 

[Muzaffer Ali]

Aşağıdaki kodları deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    Dim SonSatir As Long
    Dim EkleSil As Integer
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        If Range("B1") = "KAYDET" Then
            EkleSil = 1
        ElseIf Range("B1") = "SİL" Then
            EkleSil = -1
        End If
        With Worksheets("Kayıt")
            Set Bul = .Range("A:A").Find(what:=Range("A1").Text, LookAt:=xlWhole)
            If Bul Is Nothing Then
                If Range("B1") = "SİL" Then
                    MsgBox "Barkod kayıtlı değil, silinemiyor."
                    Exit Sub
                End If
                SonSatir = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                .Range("A" & SonSatir) = Range("A1")
                .Range("B" & SonSatir) = 1
                .Range("C" & SonSatir) = "Kayıt Tarihi: " & Date
            Else
                If Range("B1") = "SİL" And .Range("B" & Bul.Row) = 0 Then
                    MsgBox "Bu barkodun sayacı sıfırdır, silinemiyor."
                    Exit Sub
                End If
                .Range("B" & Bul.Row) = .Range("B" & Bul.Row) + EkleSil
                .Range("C" & Bul.Row) = "Değişiklik Tarihi: " & Date
            End If
        End With
    End If
End Sub

 

[leonadies]

Aynen budur Pc tarihleri değiştirip test ettim, sorunsuz ellerine sağlık @dalgalikur Çok teşekkür ederim

 

[Muzaffer Ali]

Rica ederim. İyi çalışmalar.