Soru Süzülen Veriyi Şarta Göre Aktar

[Hsn55]

Ekli makro ile sevk pusulası sayfasındaki süzülen verileri aşağıdaki makro ile MUTABAKAT TUTANAĞI ve VERİ GİRİŞİ(10) sayfalarına aktarma yapıyorum. Fakat butona tekrar bastığımda aynı veriler VERİ GİRİŞİ(10) sayfasına tekrar aktarılıyor. Mükerrer aktarım olmaması için "K" sütununda "ÖDENDİ" olanların 2. sefer aktarılmaması için makroya nasıl bir engel koyabiliriz .Yardımcı olur musunuz?
Link:

İndir AKTAR xlsm

Dosyayı indir AKTAR xlsm

dosya.co

Sub Suz_Aktar()
    Application.ScreenUpdating = False
    Sheets("MUTABAKAT TUTANAĞI").Unprotect 123
    On Error Resume Next
    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim Son, lr As Long
    Set ws = ThisWorkbook.Worksheets("SEVK PUSULASI GİRİŞİ")
    Set ws1 = ThisWorkbook.Worksheets("MUTABAKAT TUTANAĞI")
    Set ws2 = ThisWorkbook.Worksheets("VERİ GİRİŞİ(10)")
    ws1.Range("D13:K62") = ""
    ws.Activate
    Son = ws.Range("B65000").End(3).Row
    Range("B12:J" & Son).Select
    Selection.Copy
    ws1.Select
    lr = ws1.Range("D65000").End(3).Row + 1
    Range("D" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ws.Select
    Range(Range("K12:K" & Son).Address).SpecialCells(xlCellTypeVisible).Select
    Selection.Replace "ÖDENMEDİ", "ÖDENDİ"
    Range("B12:F" & Son).Select
    Selection.Copy
    ws2.Select
    lr2 = ws2.Range("a65000").End(3).Row + 1
    Range("A" & lr2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    MsgBox "Süzülen Bilgiler Aktarıldı", vbInformation, Application.UserName
    Sheets("MUTABAKAT TUTANAĞI").Protect 123
    Application.ScreenUpdating = True
End Sub

 

[muhasebeciyiz]

Sub Suz_Aktar()
    Application.ScreenUpdating = False
    Sheets("MUTABAKAT TUTANAĞI").Unprotect Password:=123
    On Error Resume Next
    
    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim Son As Long, lr As Long, lr2 As Long
    Dim i As Long
    Dim AktarilanVar As Boolean
    Dim odemeYapilsin As Boolean
    Dim rng As Range
    Dim rngTarget As Range
    Dim rngCopy As Range
    
    Set ws = ThisWorkbook.Worksheets("SEVK PUSULASI GİRİŞİ")
    Set ws1 = ThisWorkbook.Worksheets("MUTABAKAT TUTANAĞI")
    Set ws2 = ThisWorkbook.Worksheets("VERİ GİRİŞİ(10)")

    ws1.Range("D13:K62").ClearContents
    ws.Activate
    Son = ws.Range("B65000").End(xlUp).Row
    
    ' MUTABAKAT TUTANAĞI sayfasına verileri aktar
    For i = 12 To Son
        If ws.Rows(i).Hidden = False Then
            If ws.Cells(i, "K").Value <> "ÖDENDİ" Then
                If rngCopy Is Nothing Then
                    Set rngCopy = ws.Range("B" & i & ":J" & i)
                Else
                    Set rngCopy = Union(rngCopy, ws.Range("B" & i & ":J" & i))
                End If
            End If
        End If
    Next i
    
    If Not rngCopy Is Nothing Then
        rngCopy.Copy
        ws1.Select
        lr = ws1.Range("D65000").End(xlUp).Row + 1
        ws1.Range("D" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    End If
    
    ws.Select
    
    ' Ödeme yapılmasını iste
    odemeYapilsin = (MsgBox("Ödeme Yapmak İstiyor musunuz?", vbYesNo + vbQuestion, "Ödeme Onayı") = vbYes)
    
    If odemeYapilsin Then
        Set rngCopy = Nothing
        
        ' VERİ GİRİŞİ(10) sayfasına ödeme yapılacak satırları aktar ve "K" sütununu güncelle
        For i = 12 To Son
            If ws.Rows(i).Hidden = False Then
                If ws.Cells(i, "K").Value = "ÖDENMEDİ" Then
                    If rngCopy Is Nothing Then
                        Set rngCopy = ws.Range("B" & i & ":F" & i)
                    Else
                        Set rngCopy = Union(rngCopy, ws.Range("B" & i & ":F" & i))
                    End If
                    ws.Cells(i, "K").Value = "ÖDENDİ"
                    AktarilanVar = True
                End If
            End If
        Next i
        
        If Not rngCopy Is Nothing Then
            rngCopy.Copy
            ws2.Select
            lr2 = ws2.Range("A65000").End(xlUp).Row + 1
            ws2.Range("A" & lr2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End If
        
        If AktarilanVar Then
            MsgBox "Veriler hem MUTABAKAT TUTANAĞI hem de VERİ GİRİŞİ(10) sayfalarına başarıyla aktarıldı.", vbInformation, Application.UserName
        Else
            MsgBox "Ödenmemiş veri bulunamadı.", vbInformation, "Bilgi"
        End If
    Else
        MsgBox "Ödemeden Vazgeçildi.", vbInformation, "Bilgi"
    End If

    Sheets("MUTABAKAT TUTANAĞI").Protect Password:=123
    Application.ScreenUpdating = True
    ws.Activate
End Sub

ödeme yapmak isteyip istemediğinize sadece bir kez sorulur. Eğer ödeme yapmayı seçerseniz, "ÖDENMEDİ" durumundaki tüm satırlar tek seferde işlenir ve VERİ GİRİŞİ(10) sayfasına aktarılır. Bu, işlem süresini azaltır ve daha verimli bir şekilde çalışır.

 

[Hsn55]

Merhabalar PC başında olmadığım için kontrol edemiyorum kontrol sağlayınca size dönüş yapacağım şimdiden teşekkür ederim

 

[Hsn55]

Sayın arkadaşım,
Ödenenleri tekrar aktarma butonuna bastığımız da Ödeme Yapıldı. 2. Bir ödeme yapılmaz uyarısı ve ilk ödeme yapacağımız zaman ödeme yapmak istiyor musunuz evet/Hayır diye bir seçenek koyabilir misiniz?

 

[Hsn55]

Sayın muhasebeci ne yazıkki olmadı. Ödendi K sütununda ÖDENDİ olanları tekrar Veri Girişi (10) sayfasına aktarıyor. Ödenleri tekrar aktarmaması gerekiyor. 3 ve 4. mesajımıda dikkarte alırsanız sevinirim

 

[Hsn55]

Günaydın arkadaşlar, konuya destek olursanız sevinirim şimdiden teşekkür ederim

 

[muhasebeciyiz]

güncellenen kodda K sutununda yazı varsa aktarıyor hiç yazı yoksa aktarmıyor.Halbuki ödendi Ödenmedi'yi dikkate alması gerekiyor.Böyle bir denermisiniz.

 

[Hsn55]

Sayın Muhasebeci bey, boş kalınca aktarmıyor doğru. Fakat Filtre uygulayınca sadece ÖDENMEDİ olanları aktarması gerekiyor. Oysa makro ödendi olanları tekrar aktarıyor. Aktarmaması gerekiyor

 

[muhasebeciyiz]

2 nolu mesajı tekrar denerminiz

 

[Hsn55]

Sayın muhasebeci çok kasıyor. makro çok yavaş çalışıyor. Ayrıca her satırda ödenmedi olduğu zaman her birine ödeme yapmak istiyormusunuz diye soruyor. Örneğin 5 satırda ödenmedi var ben süzme yapıp aktar değimde tek seferde süzüleni aktarması gerekiyor

 

[muhasebeciyiz]

2 nolu mesajı düzenlendi deneyiniz

 

[Hsn55]

İstediğim tam bu şekilde. Ama şöyle bir durum var.
Örneğin 10 tane ödendi satırı var. 5 tanede ödenmedi var. Ödenmedi yi seçtiğimde aktar dediğimde çok kasıyor

 

[muhasebeciyiz]

2 nolu mesajı düzenledim.Kopyalanacak hücre aralıklarını önceden belirliyoruz ve topluca kopyalayıp yapıştırıyoruz. Bu, performansı artırabilir ve makronun hızını iyileştirebilir.Deneyiniz.

 

[Hsn55]

Çok teşekkür ederim .Emeğinize sağlık. Tam istediğim gibi çalışıyor. Eğer ki bir problem çıkarsa ilerde size dönüş sağlarım