makro ile veriyi başka sayfaya taşıma

[kneehot]

herkese selamlar.arkadaslar kısaca anlatmam gerekırse " j " sutunumda odendı yazan satırları baska sayfaya tasımak ve ıslem daha sonra tekrarlandıgında tasınmıs verılerın altına yenılerı ılave etmek.ornek ekledım anlasılır olması adına.yardımlarınızı beklıyorum ve tesekkur edıyorum.

 

[Orion1]

Dosyanız ektedir.

Sub odenenler_59()
Dim sh2 As Worksheet, i As Long, sat1 As Long, sat2 As Long
Sheets("DÖKÜM").Select
Set sh2 = Sheets("ÖDENEN")
sat1 = Cells(65536, "A").End(xlUp).Row
sat2 = sh2.Cells(65536, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
For i = sat1 To 4 Step -1
    If UCase(Replace(Replace(Cells(i, "J").Value, "ı", "I"), "i", "İ")) = "ÖDENDİ" Then
        If sat2 > 65533 Then
            MsgBox "ÖDENDİ sayfasında satır doldu." & vbLf & _
            "Ödenmişlerin tamamı aktarılmadı", vbCritical, "UYARI"
            Cells(i, "A").Select
            Exit Sub
        End If
        sh2.Range("A" & sat2 & ":N" & sat2).Value = Range("A" & i & ":N" & i).Value
        Rows(i).Delete
        sat2 = sat2 + 1
    End If
Next i
sh2.Select
Cells(sat2 - 1, "A").Select
Application.ScreenUpdating = True
MsgBox "ÖDENMİŞLER AKTARILDI" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[kneehot]

dosyanız ektedir.

sub odenenler_59()
dim sh2 as worksheet, i as long, sat1 as long, sat2 as long
sheets("döküm").select
set sh2 = sheets("ödenen")
sat1 = cells(65536, "a").end(xlup).row
sat2 = sh2.cells(65536, "a").end(xlup).row + 1
application.screenupdating = false
for i = sat1 to 4 step -1
    ıf ucase(replace(replace(cells(i, "j").value, "ı", "ı"), "i", "i")) = "ödendi" then
        ıf sat2 > 65533 then
            msgbox "ödendi sayfasında satır doldu." & vblf & _
            "ödenmişlerin tamamı aktarılmadı", vbcritical, "uyarı"
            cells(i, "a").select
            exit sub
        end ıf
        sh2.range("a" & sat2 & ":n" & sat2).value = range("a" & i & ":n" & i).value
        rows(i).delete
        sat2 = sat2 + 1
    end ıf
next i
sh2.select
cells(sat2 - 1, "a").select
application.screenupdating = true
msgbox "ödenmişler aktarıldı" & vblf & _
"evrengizlen@hotmail.com", vbokonly + vbınformation, "e v r e n"
end sub

cok tesekkurler umarım kendı dosyama uygulayabılırım.tekrar tesekkurler

 

[Orion1]

cok tesekkurler umarım kendı dosyama uygulayabılırım.tekrar tesekkurler

Rica ederim
İyi çalışmalar.

 

[kneehot]

Arkadaşlar merhaba, daha önce sizden yardım istediğim ve kullandığım yukarıdaki makro ile ilgili farklı bir ihtiyacım gelişti yardımcı olabilirseniz çok sevinirim. Yukarıda "J" sütununda "ödendi" yazan satırı taşıyordu, şimdiki ihtiyacım bu kriterin 2 adet olması yani hem "J" sütununda "ödendi" yazan hem de "K" sütununda "nakit yazanların taşınması. Bu iki kriterin aynı satırda doğru olması durumunda taşıma yapması. Bilenler için kolay bir güncellemedir diye düşünüyorum inşallah doğrudur Tüm yardımlara şimdiden teşekkürler.

 

[Korhan Ayhan]

10 yıl önce sorunuz yanıtlanmış.

Keşke biraz gayret gösterip makroları öğrenseydiniz.

 

[kneehot]

Biraz istediğim şekle sokabiliyorum ama ekstra bir fonksiyon eklemek gerektiğinde beni aşıyor. Çok isterdim öğrenebilmeyi ama yoğunluk buna izin vermiyor

 

[Korhan Ayhan]

Öğrenmek istiyorsanız ilk mesajınızda paylaştığınız tarzda bir örnek dosya üzerinde MAKRO KAYDET yöntemini kullanarak işlemler yapmayı deneyin. Sonra oluşan kodları okumaya çalışın. Biraz üzerine yoğunlaşırsanız yapılamayacak iş yoktur.

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Alan As Range, Son As Long
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Set S1 = Sheets("DÖKÜM")
    Set S2 = Sheets("ÖDENEN")
    
    S1.Range("A3:N" & S1.Rows.Count).AutoFilter Field:=10, Criteria1:="ÖDENDİ"
    S1.Range("A3:N" & S1.Rows.Count).AutoFilter Field:=14, Criteria1:="NAKİT"
    
    If S1.Cells(S1.Rows.Count, 1).End(3).Row = 3 Then
        If S1.AutoFilterMode Then S1.ShowAllData
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
        GoTo 10
    End If
    
    Set Alan = S1.Range("A4:N" & S1.Cells(S1.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible)
    
    If Not Alan Is Nothing Then
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row + 1
        Alan.Copy S2.Cells(Son, 1)
        Alan.EntireRow.Delete
        
        If S1.AutoFilterMode Then S1.ShowAllData
        
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        
        MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
    End If

10
    Set Alan = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[kneehot]

Arkadaşlar merhaba, bu makro ile ilgili bir sıkıntım var yardımlarınızı bekliyorum. Bu makroyu uyguladığım sayfadaki satır sayısı arttıkça makronun çalışıp bitmesi çok uzun sürmeye başladı. Makroya bir ekleme yaparak taramaya başlayacağı satır sayısını hücreden aldırmak mümkünmüdür. Örneğin B1 hücresinde 550 yazarsam 550. satırdan başlayarak işlemi uygulasın. Kullandığım tabloda satır sayısı 600 e geldi ve çalıştırdıktan sonra çok uzun süre bitmesini bekliyorum. 600 satır değil de B1 de 550 yazdığı için 550. satırdan taramaya başlarsa sadece 50 satır için çalışmış olur ve çok daha kısa sürer. Satır sayım 2000 e gelse 1 saat beklemek gerekecek diye düşünüyorum. Şimdiden yardımlara çok teşekkür ederim.

 

[Korhan Ayhan]

Önerdiğim kodun sizi bu kadar bekletmemesi gerekir. Filtre ile işlem yapıldığı için hızlı sonuç vermesi gerekir.

 

[kneehot]

Önerdiğim kodun sizi bu kadar bekletmemesi gerekir. Filtre ile işlem yapıldığı için hızlı sonuç vermesi gerekir.

Korhan bey merhaba, sizin verdiğiniz kodu ekledim fakat o kod satırın tamamını taşıdığı için kullanamadım. İstediğim hücreleri taşıtmayı yazdığınız kodda beceremedim. Yukarıda ilk yazılan kodda istediğim hücreleri taşımayı becerebildiğim için o kodu kullanmak zorunda kaldım. İstediğim yardımında o kod üzerinden bir çözümü varsa yardım ederseniz çok sevinirim.

 

[kneehot]

Sub satis_nakit_tasi()
Dim sh2 As Worksheet, i As Long, sat1 As Long, sat2 As Long
Sheets("SATIŞLAR").Select
Set sh2 = Sheets("NAKİT KASA")
sat1 = Cells(65536, "F").End(xlUp).Row
sat2 = sh2.Cells(65536, "F").End(xlUp).Row + 1
Application.ScreenUpdating = False
For i = sat1 To 4 Step -1
If UCase(Replace(Replace(Cells(i, "I").Value, "ı", "I"), "i", "İ")) = "NKT" Then
If sat2 > 65533 Then
MsgBox "İPTAL sayfasında satır doldu." & vbLf & _
"İptallerin tamamı aktarılmadı", vbCritical, "UYARI"
Cells(i, "F").Select
Exit Sub
End If
sh2.Range("F" & sat2 & ":G" & sat2).Value = Range("F" & i & ":G" & i).Value
sh2.Range("H" & sat2 & ":H" & sat2).Value = Range("J" & i & ":J" & i).Value
sh2.Range("I" & sat2 & ":I" & sat2).Value = Range("M" & i & ":M" & i).Value
sh2.Range("O" & sat2 & ":O" & sat2).Value = Range("R" & i & ":R" & i).Value
'Rows(i).Delete
sat2 = sat2 + 1
End If
Next i
Application.ScreenUpdating = True
'MsgBox "İPTALLER AKTARILDI"
End Sub


Bu şekilde istediğim hücreleri taşıyabildim

 

[kneehot]

Yardımcı olabilecek yok mu arkadaşlar

 

[Korhan Ayhan]

Bir önceki mesajınızda "Bu şekilde istediğim hücreleri taşıyabildim " diye belirtmişsiniz.

Sorununuz çözülmedi mi?

 

[kneehot]

Bir önceki mesajınızda "Bu şekilde istediğim hücreleri taşıyabildim " diye belirtmişsiniz.

Sorununuz çözülmedi mi?

Sorunum o kodu çalıştırdığım zaman çok uzun sürmesi. Dolu satır sayısı arttıkça sürede çok uzuyor. Çalışmaya başlayacağı satırı bir hücreden aldırabilirmiyiz. Örnek olarak b1 hücresinde 200 yazarsak tanımlı sütunların 200. satırından başlarsa daha kısa sürede tamamlanır diye düşünüyorum. Bu şekilde her seferinde 1. satırdan başlıyor ve 600 700 satır tarıyor. Satır sayısı 1000 1500 olduğu zaman çok daha fazla sürede tamamlanacak makronun bitmesi.

 

[Korhan Ayhan]

Çok uzun dediğiniz mesela kaç saniye ya da dakika sürüyor?

Ek olarak benim önermiş olduğum kod da olmayan yer neresi?

Örnek vererek açıklarsanız revize edebilirim. Ayrıca önerdiğim makronun işlem süresi sizin için yeterli mi?

 

[kneehot]

Çok uzun dediğiniz mesela kaç saniye ya da dakika sürüyor?

Ek olarak benim önermiş olduğum kod da olmayan yer neresi?

Örnek vererek açıklarsanız revize edebilirim. Ayrıca önerdiğim makronun işlem süresi sizin için yeterli mi?

Öncelikle ilginiz için gerçekten çok teşekkür ederim. Makronun bitmesi şu anda dolu 300 satırda yaklaşık 2 dakika sürüyor.
Sizin önerdiğiniz kodu dediğim gibi istediğim hücreleri taşıtamadığım için kullanamadım.

sh2.Range("F" & sat2 & ":G" & sat2).Value = Range("F" & i & ":G" & i).Value
sh2.Range("H" & sat2 & ":H" & sat2).Value = Range("J" & i & ":J" & i).Value
sh2.Range("I" & sat2 & ":I" & sat2).Value = Range("M" & i & ":M" & i).Value
sh2.Range("O" & sat2 & ":O" & sat2).Value = Range("R" & i & ":R" & i).Value

Diğer kodda yukarıdaki şekilde istediğim yerleri taşımayı becerebildim. O yüzden sizin kodunuzu da 300 satırda deneme şansım olmadı, diğer koda yöneldim.

Yukarıda kullandığımı belirttiğim koddaki If UCase(Replace(Replace(Cells(i, "I").Value, "ı", "I"), "i", "İ")) = "NKT" Then bu satırda belirtilen
" I " sütunda "NKT" yazanlara işlem yaparken her seferinde ilk satırdan başlayıp sütunun tamamını tarıyor. Buraya başlangıç satır sayısının bir hücreden aldırılmasını sağlayacak bir ek ile işlem süresini kısaltabiliriz diye düşündüm. Bugün 300 satır dolu fakat 1 ay sonra 600 satıra çıkınca 600 satırı taraması ile işlem süresi çok daha fazla uzayacaktır. Umarım sıkıntımı anlatabilmişimdir.

Tekrar yardımlarınız için çok teşekkür ederim.

 

[Korhan Ayhan]

Öncelikle döngü bile olsa 300 satırlık veride 2 dakika sürmesi anormal görünüyor.

Asıl dosyanızın boyutu nedir? Yoğun formül kullanımı var mı? Bunlar süreyi etkileyebilir.

Ek olarak benim önerdiğim kodu ilk mesajda ki örnek dosyanızda denediğimde yaklaşık 1-2 saniyede işlemi tamamlıyor.

Önerdiğim kod kısaca şu işlemi yapıyor;

J sütununda ÖDENDİ yazanları süzüyor.
N sütununda NAKİT yazanları süzüyor.

Eğer bu koşullara uyan satırlar varsa bunları ÖDENEN sayfasındaki var olan verilerin altına aktarıyor. Sonrasında aktarılan satırları DÖKÜM sayfasından satır olarak siliyor.

Sizin istediğiniz işlem bu değil miydi?

 

[kneehot]

Korhan bey merhaba,
Öncelikle bu kodu bu konunun başında eklediğim excel tablosunda kullanmıyorum ayrıca kodu tam yazıldığı şekilde de kullanmıyorum. Becerebildiğim kadarıyla ihtiyacıma göre güncelledim. Örneğin ilk tabloda belirtilmiş sütun aralığındaki kurallara uyan satırları kopyalayıp diğer sayfaya yapıştırıyor ve kopyaladığı satırları da siliyordu. Ben kopyala yapıştır yaptırarak kopyalanan veriyi de sildirmiyorum. Benim kullanma şeklim şu şekilde değişti.



Yeşil ile çizilmiş yani "I" sütununda "NKT" yazan satırlardaki F,G,J ve M sütunlarındaki değerleri kopyalayıp farklı sayfadaki bazen aynı sütünlara bazende farklı sütünlara yapıştırıyorum. Yukarıdaki sayfadaki "NKT" yazısınıda "NAKİT" olarak değiştirtiyorum ki makro tekrar çalıştığında aynı yerleri tekrar kopyalamasın.
sh2.Range("F" & sat2 & ":G" & sat2).Value = Range("F" & i & ":G" & i).Value
sh2.Range("H" & sat2 & ":H" & sat2).Value = Range("J" & i & ":J" & i).Value
sh2.Range("I" & sat2 & ":I" & sat2).Value = Range("M" & i & ":M" & i).Value

Bakın burada "I" sütununda "NKT" yazan satırlardaki "F ve G" hücrelerindeki veriyi Diğer sayfada "F ve G" ye
"J" hücresindeki veriyi diğer sayfada "H" ye
"M" hücresindeki veriyi diğer sayfada "I" ya
kopyalamışım.

Belki de bu kadar çok farklı işlem yaptırdığım için yavaş çalışıyordur diye düşünüyorum fakat bilgim yapmak istediğimi anca bu şekilde becermeme yetti. Örnekte de gördüğünüz gibi 372 satırım dolu daha fakat artmakta. 372. satırdayken makroyu çalıştırdıktan sonra bir sonraki çalıştırışımda en üstteki 300 satır boşuna taranan alan benim için. 72 satırlık bir opsiyon bırakıyorum üstte çünkü belki araya sonradan eklenmiş satırlar olabilir diye ama sonuç olarak makro her çalıştığında ilk satırdan itibaren tarama yapması benim için gereksiz ve zaman kaybettirici. Sizden ricam bu makroya bir ilave yaparak sorunuma çare olmanızdır. Çünkü tüm çalışma kitabında bir çok yere bu makrodan ekledim ve bambaşka bir makroyu bu alanlara adapte etmem çok zamanımı alacaktır. Küçük bir ek yapmak daha çok işime geliyor.

 

[Korhan Ayhan]

Resim yerine dosyanıza satır ve sütun bakımından benzer bir örnek dosya paylaşırsanız önereceğimiz kodları deneme şansımız olur.