Soru Fiş Kaydetme ve Güncelleme

[leonadies]

Üstadlar Merhaba;

İki Sekmem var "Giriş" Sekmesi ve "Kayıt" Sekmesi

"GİRİŞ" E:E de Fiş numaraları J,K,L sütunlarında da o fişe dair durum tarih ve notlar var.

İsteğim şöyle" GİRİŞ" Sekmesi J:J sütununda yaptığım işlemi "KAYIT" Sekmesine Fiş no,Durum, tarih,not şeklinde "Kaydet" butonu ile kaydetmesi
Bunu yaparken de "KAYIT" sekmesinde fişin daha önce kaydedilmiş durumu varsa o satırı silip güncel halini en alta yeniden kaydetmesi. (mükerrer kayıt olmaması diyeyim)

Yani örneğin 192 nolu fişi bugün bekliyor diye "KAYIT" sekmesine yazdırdıysam, Yarın geldiğinde onu "Geldi" yapıp Kaydet butonuna bastığımda "KAYIT" sekmesindeki eski halinin satırını silmeli ve yeni halini yazmalı.

Not: Giriş sekmesi 20 bin satıra kadar bile gidebilir.

Yapılabilir mi?

 

[ÖmerFaruk]

Giriş sekmesinde var olan veriler,
kayıt sayfasında yoksa olduğu gibi kayıt sayfasına yazılacak.
kayıt sayfasında varsa, o satır yeni değerlerle güncellenecek.

Bu mudur?

 

[leonadies]

Giriş sekmesinde var olan veriler,
kayıt sayfasında yoksa olduğu gibi kayıt sayfasına yazılacak.
kayıt sayfasında varsa, o satır yeni değerlerle güncellenecek.

Bu mudur?

Aynen Üstadım

 

[ÖmerFaruk]

1. Her kayıt işleminden sonra Gİriş sayfasındaki veriler silinecek mi?
2. Yoksa iki sayfa karşılaştırılıp, kayıt sayfasında olmayan fiş nosu kayıt sayfasıne en son satıra kaydedilecek, kayıt sayfasında var olan fiş nosunun olduğu satır silinip yenisi yine en son satıra kaydedilecek?

teyit eder misiniz?

 

[leonadies]

1. Her kayıt işleminden sonra Gİriş sayfasındaki veriler silinecek mi?
2. Yoksa iki sayfa karşılaştırılıp, kayıt sayfasında olmayan fiş nosu kayıt sayfasıne en son satıra kaydedilecek, kayıt sayfasında var olan fiş nosunun olduğu satır silinip yenisi yine en son satıra kaydedilecek?

teyit eder misiniz?

1-Giriş Sayfasındaki Veriler hiç silinmeyecek olduğu gibi kalacak.
2-Evet.

 

[leonadies]

Güncel

 

[ÖmerFaruk]

Madem hiç silinmeyecek, neden kopyala yapıştır yapmıyorsunuz?
Eğer bu sorumun cevabı olumsuz ise
Ya ben sorunuzu anlayamadım ya da siz eksik tarif ediyorsunuz?

 

[leonadies]

Madem hiç silinmeyecek, neden kopyala yapıştır yapmıyorsunuz?
Eğer bu sorumun cevabı olumsuz ise
Ya ben sorunuzu anlayamadım ya da siz eksik tarif ediyorsunuz?

üstadım çalışmam komplike özet çalışma ile anlatmaya çalıştım kafa yormamak için.
Giriş sekmesindeki her satır değişken fiş numalaralı ile değişebiliyor. bana lazım olan o an ordaki bilgileri KAYIT sekmesine atıp devam etmek,
Örneğin E5 de 175 nolu fiş varsa onu kayıt altına almış oluyorum böylelikle 5 gün sonra E5 e 245 nolu fiş düşerse onuda kayıt altına almış olucam yani Giriş sekmesindeki bilgiler Dinamil ve değişken. Sadece başka bir sekmeye bunları sürekli kayıt altına alma derdindeyim.

 

[veyselemre]

Sub Kaydet()
    Application.ScreenUpdating = False
    Dim veri, w(1 To 1, 1 To 4), i&, ky$, y, dic As Object, son&, itms
    
    With Sheets("Giriş")
        veri = .Range("E2:L" & .Cells(Rows.Count, "J").End(3).Row)
    End With
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For i = LBound(veri) To UBound(veri)
        If veri(i, 6) <> "" Then
            ky = veri(i, 1)
            If Not dic.exists(ky) Then
                w(1, 1) = ky
                w(1, 2) = veri(i, 6)
                w(1, 3) = veri(i, 7)
                w(1, 4) = veri(i, 8)
                dic.Item(ky) = w
            Else
                y = dic.Item(ky)
                y(1, 2) = veri(i, 6)
                y(1, 3) = veri(i, 7)
                y(1, 4) = veri(i, 8)
                dic.Item(ky) = y
            End If
        End If
    Next i
    
    With Sheets("Kayıt")
        
        son = .Cells(Rows.Count, "A").End(3).Row
        
        If son > 1 Then
            For i = 2 To son
                ky = .Cells(i, 1).Value
                If dic.exists(ky) Then
                    .Rows(i).ClearContents
                End If
            Next i
        End If
        
        son = .Cells(Rows.Count, "A").End(3).Row + 1
        itms = dic.items
        
        For Each y In itms
            .Cells(son, 1).Resize(, 4).Value = y
            son = son + 1
        Next y
        
        If WorksheetFunction.CountBlank(.Range("A2:A" & son)) > 0 Then
            .Range("A2:A" & son).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If
    
    End With
            
    Application.ScreenUpdating = True
End Sub

 

[leonadies]

Sub Kaydet()
    Application.ScreenUpdating = False
    Dim veri, w(1 To 1, 1 To 4), i&, ky$, y, dic As Object, son&, itms
   
    With Sheets("Giriş")
        veri = .Range("E2:L" & .Cells(Rows.Count, "J").End(3).Row)
    End With
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    For i = LBound(veri) To UBound(veri)
        If veri(i, 6) <> "" Then
            ky = veri(i, 1)
            If Not dic.exists(ky) Then
                w(1, 1) = ky
                w(1, 2) = veri(i, 6)
                w(1, 3) = veri(i, 7)
                w(1, 4) = veri(i, 8)
                dic.Item(ky) = w
            Else
                y = dic.Item(ky)
                y(1, 2) = veri(i, 6)
                y(1, 3) = veri(i, 7)
                y(1, 4) = veri(i, 8)
                dic.Item(ky) = y
            End If
        End If
    Next i
   
    With Sheets("Kayıt")
       
        son = .Cells(Rows.Count, "A").End(3).Row
       
        If son > 1 Then
            For i = 2 To son
                ky = .Cells(i, 1).Value
                If dic.exists(ky) Then
                    .Rows(i).ClearContents
                End If
            Next i
        End If
       
        son = .Cells(Rows.Count, "A").End(3).Row + 1
        itms = dic.items
       
        For Each y In itms
            .Cells(son, 1).Resize(, 4).Value = y
            son = son + 1
        Next y
       
        If WorksheetFunction.CountBlank(.Range("A2:A" & son)) > 0 Then
            .Range("A2:A" & son).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If
   
    End With
           
    Application.ScreenUpdating = True
End Sub

Üstadım Eline sağlık ancak şurada hata alıyorum. "hiçbir hücre bulunamadı" şeklinde.
.Range("A2:A" & son).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

 

[veyselemre]

Uyguladığınız dosyayı ekler misiniz?
Zira boş hücre olup olmadığı kodda kontrol ediliyor. Boş hücre yok ise silme işlemi yapılmayacak.

 

[leonadies]

Uyguladığınız dosyayı ekler misiniz?
Zira boş hücre olup olmadığı kodda kontrol ediliyor. Boş hücre yok ise silme işlemi yapılmayacak.

ilk mesajda eklediğim örnek excelde alıyorum bu hatayı üstadım. Onda deneyince bu hata çıkıyor.

 

[veyselemre]

Sub Kaydet()
    Application.ScreenUpdating = False
    Dim veri, w(1 To 1, 1 To 4), i&, ky$, y, dic As Object, son&, itms
    
    With Sheets("Giriş")
        veri = .Range("E2:L" & .Cells(Rows.Count, "J").End(3).Row)
    End With
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For i = LBound(veri) To UBound(veri)
        If veri(i, 6) <> "" Then
            ky = veri(i, 1)
            If Not dic.exists(ky) Then
                w(1, 1) = ky
                w(1, 2) = veri(i, 6)
                w(1, 3) = veri(i, 7)
                w(1, 4) = veri(i, 8)
                dic.Item(ky) = w
            Else
                y = dic.Item(ky)
                y(1, 2) = veri(i, 6)
                y(1, 3) = veri(i, 7)
                y(1, 4) = veri(i, 8)
                dic.Item(ky) = y
            End If
        End If
    Next i
    
    With Sheets("Kayıt")
        
        son = .Cells(Rows.Count, "A").End(3).Row
        
        If son > 1 Then
            For i = 2 To son
                ky = .Cells(i, 1).Value
                If dic.exists(ky) Then
                    .Rows(i).ClearContents
                End If
            Next i
        End If
        
        son = .Cells(Rows.Count, "A").End(3).Row + 1
        itms = dic.items
        
        For Each y In itms
            .Cells(son, 1).Resize(, 4).Value = y
            son = son + 1
        Next y
    
        With .Range("A2:A" & son - 1)
            If WorksheetFunction.CountBlank(.Cells) > 0 Then
                .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            End If
        End With
    
    End With
            
    Application.ScreenUpdating = True
End Sub

 

[leonadies]

Sub Kaydet()
    Application.ScreenUpdating = False
    Dim veri, w(1 To 1, 1 To 4), i&, ky$, y, dic As Object, son&, itms
   
    With Sheets("Giriş")
        veri = .Range("E2:L" & .Cells(Rows.Count, "J").End(3).Row)
    End With
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    For i = LBound(veri) To UBound(veri)
        If veri(i, 6) <> "" Then
            ky = veri(i, 1)
            If Not dic.exists(ky) Then
                w(1, 1) = ky
                w(1, 2) = veri(i, 6)
                w(1, 3) = veri(i, 7)
                w(1, 4) = veri(i, 8)
                dic.Item(ky) = w
            Else
                y = dic.Item(ky)
                y(1, 2) = veri(i, 6)
                y(1, 3) = veri(i, 7)
                y(1, 4) = veri(i, 8)
                dic.Item(ky) = y
            End If
        End If
    Next i
   
    With Sheets("Kayıt")
       
        son = .Cells(Rows.Count, "A").End(3).Row
       
        If son > 1 Then
            For i = 2 To son
                ky = .Cells(i, 1).Value
                If dic.exists(ky) Then
                    .Rows(i).ClearContents
                End If
            Next i
        End If
       
        son = .Cells(Rows.Count, "A").End(3).Row + 1
        itms = dic.items
       
        For Each y In itms
            .Cells(son, 1).Resize(, 4).Value = y
            son = son + 1
        Next y
   
        With .Range("A2:A" & son - 1)
            If WorksheetFunction.CountBlank(.Cells) > 0 Then
                .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            End If
        End With
   
    End With
           
    Application.ScreenUpdating = True
End Sub

Eline Sağlık üstadım. Sorunsuz çalışmakta