makro ile veriyi başka sayfaya taşıma

[kneehot]

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.

Dosya ekledim anlaşılır olmuştur diye umuyorum.

 

[Korhan Ayhan]

Son eklediğiniz dosyaya göre #5 nolu mesajınızda ki talebinizi nasıl değerlendirmeliyiz?

J ve K sütunlarına göre kriterleriniz vardı. Bunları hangi sütunlara göre yorumlamalıyız?

 

[kneehot]

Son eklediğiniz dosyaya göre #5 nolu mesajınızda ki talebinizi nasıl değerlendirmeliyiz?

J ve K sütunlarına göre kriterleriniz vardı. Bunları hangi sütunlara göre yorumlamalıyız?

#5 nolu mesajımda amacım taşınanları ayırmaktı. Örnek olarak nakit yazan ve yan hücresinde kopyala yazanların işlem görmesiydi fakat eklediğiniz yeni kodda istediğim hücreleri taşımayı beceremeyince bende tek sütunda NKT yazanları kopyalatıp sonrada NKT olanları NAKİT e çevirterek bu sorunu çözmeye çalıştım. Sonuç olarak şu anda 2li kritere ihtiyacım kalmadı bu yöntemle.

 

[Korhan Ayhan]

Şöylede yapılabilir.

Boş bir sütuna (mesela S sütunu) aktarılanlar için "Aktarıldı" ya da benzer bir ifade yazdırılabilir. Bir sonraki aktarım işleminde bu S sütunu boş olanlar aktarılabilir.

Bu şekilde kullanım sizin için uygun olur mu?

 

[kneehot]

Şöylede yapılabilir.

Boş bir sütuna (mesela S sütunu) aktarılanlar için "Aktarıldı" ya da benzer bir ifade yazdırılabilir. Bir sonraki aktarım işleminde bu S sütunu boş olanlar aktarılabilir.

Bu şekilde kullanım sizin için uygun olur mu?

Evet uygun olur fakat yeni kodda istediğim hücreleri taşıma şansım olabilecek mi? Çünkü bu tabloda farklı alanlarda kullandım bu makroyu kendim uygulama yapabilir miyim bilemedim diğer taraflara.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satir As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.EnableEvents = 0
    
    Set S1 = Sheets("SATIŞLAR")
    Set S2 = Sheets("NAKİT KASA")
    
    S1.ListObjects(1).Range.AutoFilter Field:=8, Criteria1:="NAKİT"
    S1.ListObjects(1).Range.AutoFilter Field:=18, Criteria1:="<>Aktarıldı"
    
    Son = S1.ListObjects(1).Range.Columns(8).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    If Son = 3 Then
        If S1.ListObjects(1).AutoFilter.FilterMode Then S1.ListObjects(1).AutoFilter.ShowAllData
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
        GoTo 10
    End If
    
    Satir = S2.ListObjects(1).Range.Columns(5).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    
    S1.ListObjects(1).ListColumns(5).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    S2.Range("F" & Satir).PasteSpecial xlPasteValues
    S1.ListObjects(1).ListColumns(6).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    S2.Range("G" & Satir).PasteSpecial xlPasteValues
    S1.ListObjects(1).ListColumns(9).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    S2.Range("H" & Satir).PasteSpecial xlPasteValues
    S1.ListObjects(1).ListColumns(12).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    S2.Range("I" & Satir).PasteSpecial xlPasteValues
        
    S1.ListObjects(1).ListColumns(18).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "Aktarıldı"
        
    If S1.ListObjects(1).AutoFilter.FilterMode Then S1.ListObjects(1).AutoFilter.ShowAllData
        
    Application.EnableEvents = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
        
    MsgBox "Veri aktarımı tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
10
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[kneehot]

Çok teşekkür ederim gerçekten yardımlarınız ve bıkmadan ilgilendiğiniz için çok sağ olun. Kodla ilgili tek sorum yapıştıracağı yerdeki satır başlangıç sayısını nereden alıyor?

If Son = 3 Then

yazan yer en olabilir göründü doğru mudur?

 

[Korhan Ayhan]

Bir önceki mesajımda ki kod varolan verinize göre kısa sürede işlemi yapıyor. Veri sayısını 20.000 civarına çıkardığımda çok fazla bekletiyor. Sanırım excelin "Tablo" özelliğinden dolayı bu şekilde davranıyor.

Aşağıdaki kod dizi mantığı ile çalıştığı için daha hızlı sonuç vermektedir. 20.000 satırda ben de yaklaşık 6 saniyede işlemi tamamlıyor.

Eğer excelin "Tablo" özelliğini kullanmaktan vazgeçerseniz büyük ihtimalle kodlar daha hızlı tepki verecektir.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Satir As Long
    Dim Veri As Variant, X As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.EnableEvents = 0
    
    Set S1 = Sheets("SATIŞLAR")
    Set S2 = Sheets("NAKİT KASA")
    
    If S1.ListObjects(1).AutoFilter.FilterMode Then S1.ListObjects(1).AutoFilter.ShowAllData
    
    Veri = S1.ListObjects(1).DataBodyRange.Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 4)
    ReDim Onay(1 To UBound(Veri, 1), 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 8) = "NAKİT" Then
            If Veri(X, 18) = "" Then
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 5)
                Liste(Say, 2) = Veri(X, 6)
                Liste(Say, 3) = Veri(X, 9)
                Liste(Say, 4) = Veri(X, 11)
                Onay(X, 1) = "Aktarıldı"
            End If
        End If
    Next
    
    If Say > 0 Then
        Satir = S2.ListObjects(1).Range.Columns(5).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        S2.Range("F" & Satir).Resize(Say, 4).Value = Liste
        S1.ListObjects(1).ListColumns(18).DataBodyRange.Value = Onay
        
        Application.EnableEvents = 1
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
            
        MsgBox "Veri aktarımı tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[kneehot]

Anladım, çok teşekkür ederim

 

[kneehot]

Option Explicit

Sub Aktar_malalis_nakitkasa()
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Satir As Long, Zaman As Double

Zaman = Timer

Application.ScreenUpdating = 0
Application.Calculation = -4135
Application.EnableEvents = 0

Set S1 = Sheets("MAL ALIŞ")
Set S2 = Sheets("NAKİT KASA")

S1.ListObjects(1).Range.AutoFilter Field:=9, Criteria1:="NAKİT"
S1.ListObjects(1).Range.AutoFilter Field:=17, Criteria1:="<>Aktarıldı"

Son = S1.ListObjects(1).Range.Columns(9).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

If Son = 3 Then
If S1.ListObjects(1).AutoFilter.FilterMode Then S1.ListObjects(1).AutoFilter.ShowAllData
Application.Calculation = -4105
Application.ScreenUpdating = 1
MsgBox "Uygun kayıt bulunamadı!", vbExclamation
GoTo 10
End If

Satir = S2.ListObjects(1).Range.Columns(5).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

S1.ListObjects(1).ListColumns(4).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
S2.Range("F" & Satir).PasteSpecial xlPasteValues
S1.ListObjects(1).ListColumns(5).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
S2.Range("G" & Satir).PasteSpecial xlPasteValues
S1.ListObjects(1).ListColumns(6).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
S2.Range("H" & Satir).PasteSpecial xlPasteValues
S1.ListObjects(1).ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
S2.Range("J" & Satir).PasteSpecial xlPasteValues
S1.ListObjects(1).ListColumns(3).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
S2.Range("O" & Satir).PasteSpecial xlPasteValues

S1.ListObjects(1).ListColumns(17).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "Aktarıldı"

If S1.ListObjects(1).AutoFilter.FilterMode Then S1.ListObjects(1).AutoFilter.ShowAllData

Application.EnableEvents = 1
Application.Calculation = -4105
Application.ScreenUpdating = 1

MsgBox "Mal Alış Nakit Harcama aktarımı tamamlanmıştır." & vbLf & vbLf & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
10
Set S1 = Nothing
Set S2 = Nothing
End Sub



Korhan Bey merhaba, verdiğiniz kodu başka bir sayfada uyguladığımda kopyalama işlemini yapıyor fakat tekrar çalıştırınca makroyu uygun veri bulunamadı mesajını çıkartmak yerine kodda yukarıda kırmızı ile işaretlediğim yeri sarı ile boyayıp üstteki hatayı veriyor. Neresinde yanlış yapıyorum çözemedim

 

[Korhan Ayhan]

Uyguladığınız sayfa satır ve sütun olarak örnek dosyadaki gibiyse sorun olmaması gerekir. O uyarıyı vermesi için Son değişkeninin 3 değerini alması gerekir. Bunları kontrol ediniz. Çözemiyorsanız örnek dosyanızı paylaşınız.

 

[kneehot]

Uyguladığınız sayfa satır ve sütun olarak örnek dosyadaki gibiyse sorun olmaması gerekir. O uyarıyı vermesi için Son değişkeninin 3 değerini alması gerekir. Bunları kontrol ediniz. Çözemiyorsanız örnek dosyanızı paylaşınız.

Korhan bey çözemedim Örnek dosyayı ekledim. Sizden ricam nerede hata yapıyormuşum bana da söylerseniz tekrar tekrar rahatsız etmek istemem sizi. Yardımınız için çok teşekkürler.

 

[Korhan Ayhan]

MAL ALIŞ sayfasında veriler 4. satırdan başlıyor. Bu sebeple hata alıyorsunuz.

Aşağıdaki satırdaki değeri 4 olarak değiştirip deneyiniz.

If Son = 3 Then

 

[kneehot]

MAL ALIŞ sayfasında veriler 4. satırdan başlıyor. Bu sebeple hata alıyorsunuz.

Aşağıdaki satırdaki değeri 4 olarak değiştirip deneyiniz.

If Son = 3 Then

4 olarak değiştirince düzeldi çok teşekkür ederim

 

[nazifdural]

Öğ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

Hocam aynı kolonda, Ödendi, Tahsil, Karşılıksız, Ciro, Hukiki Takip açıklamalarını da aktarmak istiyorum.
Bunu nasıl yapabilirim.

 

[Korhan Ayhan]

Boş bir excel açtım.
A sütununa bir başlık ekledim.
Altına rastgele veriler yazdım. Sizin kriterleride yazdım.

Sonra MAKRO KAYDET yöntemi ile gerekli filtre işlemini yaptım. Oluşan kodu aşağıdaki gibi düzenledim.

Oluşan Kod;

Sub Makro1()
'
' Makro2 Makro
'

'
    ActiveSheet.Range("$A$1:$A$1000").AutoFilter Field:=1, Criteria1:=Array( _
        "Ciro", "Hukiki Takip", "Karşılıksız", "Ödendi", "Tahsil"), Operator:= _
        xlFilterValues
End Sub

Düzenlenmiş Kod;

Sub Filtre()
    Dim My_Criteria As Variant
    My_Criteria = Array("Ciro", "Hukiki Takip", "Karşılıksız", "Ödendi", "Tahsil")
    Range("A1:A1000").AutoFilter Field:=1, Criteria1:=My_Criteria, Operator:=xlFilterValues
End Sub