Sütun Kopyalama (bazı kuralllara göre)

[leonadies]

Üstadlar Merhaba;

Bir excel dosyam var;

Yapmaya çalıştığım şey;
-Öncelikle Durum sutununda boş olmayan hücreleri filtrelemek
-Filtrelenmiş bu durumların karşısına denk gelen satırları "Depo" Sekmesine belirtilen sütun sırasına göre son dolu hücreyi bularak kopyalamak

**Kopyalama sırasında özel olarak istedğim ise;

-Kopyalama yaparken Depo sekmesinde Daha önce o fiş numarasına yapılmış aktarım varsa o satırı bulup silsin.

-"Aktar" butonuna basıldığı anda depoya yaptığı aktarımı "Aktarma saati olarak hücre karşısına yazsın"

Dosyalarımı da ekledim.

 

[EmrExcel16]

Deneyiniz..

Option Explicit

Sub Aktar()
    Dim SayfG, SayfD, SonSatG, SonSatD, Bul, Rng
    Set SayfG = Sheets("Giris")
    Set SayfD = Sheets("Depo")
    
    SonSatG = SayfG.Cells(Rows.Count, 3).End(3).Row
    SonSatD = SayfD.Cells(Rows.Count, 1).End(3).Row + 1
    
    SayfG.AutoFilterMode = False
    SayfG.Range(SayfG.Cells(1, 3), SayfG.Cells(SonSatG, 9)).AutoFilter Field:=1, Criteria1:="<>"
    
    For Each Rng In Range("C2:C" & SonSatG).SpecialCells(xlCellTypeVisible)
    
    
        Set Bul = SayfD.Range("A2:A100000").Find(Cells(Rng.Row, 9), , xlValues, xlWhole)
        If Not Bul Is Nothing Then
        
            SayfD.Cells(Bul.Row, 1) = SayfG.Cells(Rng.Row, 9)
            SayfD.Range(SayfD.Cells(Bul.Row, 2), SayfD.Cells(Bul.Row, 4)).Value = _
            SayfG.Range(SayfG.Cells(Rng.Row, 3), SayfG.Cells(Rng.Row, 5)).Value
            SayfD.Cells(Bul.Row, 5) = Now
            
        Else
        
            SayfD.Cells(SonSatD, 1) = Cells(Rng.Row, 9)
            SayfD.Range(SayfD.Cells(SonSatD, 2), SayfD.Cells(SonSatD, 4)).Value = _
            SayfG.Range(SayfG.Cells(Rng.Row, 3), SayfG.Cells(Rng.Row, 5)).Value
            SayfD.Cells(SonSatD, 5) = Now
            SonSatD = SonSatD + 1
            
        End If
        
    Next
    SayfD.Range("A2:E" & SonSatD).Sort Key1:=SayfD.[E2], Order1:=xlAscending
    MsgBox "İşlem Tamam..."

End Sub

 

[leonadies]

Üstadım Ellerine sağlık
Bir iki sorunu daha çözersek daha ii olacak
Bu alan dinamik bir alan olacak dolayısıyla aktarım yaparken DEPO sekmesi A sutununudaki son dolu hücreye yazarsa eski veriler korunmuş olacak. ancak fişin geçmişde yapılmış hareketi varsa aktarım yaparken onu DEPO sekmesinde bulup o satırı silmesi olayına yine sayfanın tamamında bakmalı.

 

[EmrExcel16]

DEPO sekmesi A sutununudaki son dolu hücreye yazarsa eski veriler korunmuş olacak. ancak fişin geçmişde yapılmış hareketi varsa aktarım yaparken onu DEPO sekmesinde bulup o satırı silmesi

Verdiğim kodlar tam olarak da bunu yapması gerekiyor, örnek vererek açıklar mısınız sorunu..

 

[leonadies]

Üstadım; Evet fiş noları değiştirdiğimde sorun olmadığını gördüm. Örneği şöyle vereyim. Giriş sekmede bir fiş numarasının durum,tarih,açıklama hücrelerini boşaltınca bunu son hal olarak algılamıyor. Eski hali depo da kayıtlı kalıyor. Oraya da bir çare bulsak başka sorun kalmamış olacak.

 

[EmrExcel16]

Şimdi şöyle bir durum var , "Durum" kısmına filtre uygulayıp boş olanları es geçtiği için olabilir mi ? , kodları ona göre yazdık. O yüzden "Durum" kısmındaki boş olanları "Depo" sayfasında kontrol etmiyor..

 

[leonadies]

Evet farkındayım. İşte çözebilirmiyizin peşindeyim
Ben filtreleyip almayı düşündüm aöa Belki bunun yerine dolu hücreleri al dememiz daha doğru bir adımdır.

"Bu arada bildirimler için bana mail niçin düşmüyor anlamıyorum. Sitenizin veritabanı değiştikten sonra bu sorunu yaşıyorum."

 

[EmrExcel16]

Ben filtreleyip almayı düşündüm aöa Belki bunun yerine dolu hücreleri al dememiz daha doğru bir adımdır.

Anladım ama buna karar vermeniz gerekir,"Fiş No" kısımındaki bütün hücreleri kontrol ettirmek istiyorsanız,

Aşağıdaki kodları kullanabilirsiniz .

Option Explicit

Sub Aktar()
    Dim SayfG, SayfD, SonSatG, SonSatD, Bul, Rng
    Set SayfG = Sheets("Giris")
    Set SayfD = Sheets("Depo")
   
    SonSatG = SayfG.Cells(Rows.Count, 9).End(3).Row
    SonSatD = SayfD.Cells(Rows.Count, 1).End(3).Row + 1
    SayfG.AutoFilterMode = False
   
    For Rng = 2 To SonSatG
       
        Set Bul = SayfD.Range("A2:A100000").Find(Cells(Rng, 9), , xlValues, xlWhole)
        If Not Bul Is Nothing Then
            If SayfG.Cells(Rng, 3) <> "" Then
                SayfD.Cells(Bul.Row, 1) = SayfG.Cells(Rng, 9)
                SayfD.Range(SayfD.Cells(Bul.Row, 2), SayfD.Cells(Bul.Row, 4)).Value = _
                SayfG.Range(SayfG.Cells(Rng, 3), SayfG.Cells(Rng, 5)).Value
                SayfD.Cells(Bul.Row, 5) = Now
            Else
                SayfD.Range(SayfD.Cells(Bul.Row, 1), SayfD.Cells(Bul.Row, 5)).ClearContents
            End If
        Else
            If SayfG.Cells(Rng, 3) <> "" Then
                SayfD.Cells(SonSatD, 1) = Cells(Rng, 9)
                SayfD.Range(SayfD.Cells(SonSatD, 2), SayfD.Cells(SonSatD, 4)).Value = _
                SayfG.Range(SayfG.Cells(Rng, 3), SayfG.Cells(Rng, 5)).Value
                SayfD.Cells(SonSatD, 5) = Now
                SonSatD = SonSatD + 1
            End If
        End If
    Next
   
    SayfG.Range(SayfG.Cells(1, 3), SayfG.Cells(SonSatG, 9)).AutoFilter Field:=1, Criteria1:="<>"

    SayfD.Range("A2:E" & SonSatD).Sort Key1:=SayfD.[E2], Order1:=xlAscending
    MsgBox "İşlem Tamam..."

End Sub

"Bu arada bildirimler için bana mail niçin düşmüyor anlamıyorum. Sitenizin veritabanı değiştikten sonra bu sorunu yaşıyorum."

Bu konu hakkında hata olduğunu düşünüyorsanız, Hüseyin Beye iletebilirsiniz..

 

[leonadies]

Oldu bu kod üstadım. Sadece en son satıra yapılan giriş durumu aktardıktan sonra yeniden değişirse sorun oluyor. Onuda altına bir veri girince bi dahaki sefere aktarırken düzeltiyor. Çok teşekkür ederim

 

[EmrExcel16]

O sorunu da düzeltelim o zaman, ama bu konuda örnek vererek anlatırsanız sevinirim.

 

[leonadies]

Tabi. Son eklediğim bu dosyada açar açmaz aktar yapalım. Sonra gidip depoda durumuna bakalım. Sorun yok aktardı.
Şimdi C17:E17 aralığını silelim aktar diyelim. Depoya geldiğimizde En üste attığını ve eski halinin kaldığını görüyoruz. Dediğim gibi sadece son satıra yazılan duruma yapıyor bunu. Diğer ara satırlarda sorunu yok
Ancak alta bir fiş daha eklersek bu sorun yine çözülüyor

 

[EmrExcel16]

Şimdi daha anlaşılır oldu , bu doğrultuda #8 nolu mesajımdaki kodları güncelledim , deneyip sonucu bildirirsiniz..

 

[leonadies]

Çok teşekkürler artık sıfır sorun

 

[EmrExcel16]

Çok teşekkürler artık sıfır sorun

Rica ederim , iyi çalışmalar.