Kopyalama çok yavaş (copy - pastespecial)

[Abdilaka]

Merhaba data üzerinde segmentasyon için bi çalışma yapıyorum yaklaşık 8 farklı filtre ile 8 ayrı sayfaya ayrılacak 230 bin satırlık data var.

For each döngüsü ile döndürüp if else ile filtreleyip yapıyorum ama tek tek satır tarayıp işlemi yapması 10 dakikayı buluyor. 8 filtre 1 saati aşıyor.

Daha hızlı bir kopyalama mümkün müdür?

Kodlar:

Sub Evn_sekiz()

    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim s3 As Worksheet
    Dim s4 As Worksheet
    Dim s5 As Worksheet
    Dim s6 As Worksheet
    Dim s7 As Worksheet
    

    Dim bul As Range
    

    Dim satır As Long
  
    satır = 1

    

    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Set s3 = Sheets("Sayfa3")
    Set s4 = Sheets("Sayfa4")
    Set s5 = Sheets("Sayfa5")
    Set s6 = Sheets("Sayfa6")
   

    Application.ScreenUpdating = False
    
        
  
For Each bul In s1.Range("A2:A" & s1.Range("A550536").End(3).Row)
     

    If (s1.Cells(bul.Row, "F").Value >= 500000 Or s1.Cells(bul.Row, "G").Value >= s6.Range("AQ14").Value Or _
    s1.Cells(bul.Row, "I").Value >= s6.Range("AQ14").Value) Then
    satır = satır + 1
    bul.EntireRow.Copy
    s5.Select
    Cells(satır, 1).PasteSpecial
     
    
    End If
   
    Next bul
    
    
    [A2].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
   
    
End Sub

 

[Ömer BARAN]

Merhaba.

Örnek belge olmadığından ister istemez varsayımlarda bulunmak gerekiyor.

Verdiğiniz kod'da sayfa döngüsü göremedim.

Kod'da Sayfa1 isimli sayfanın;
-- F sütunundaki değer 500.000'den büyük veya eşit YA DA
-- G sütunu Sayfa6 isimli sayfanın AQ14 hücresine eşit YA DA
-- I sütunu Sayfa6 isimli sayfanın AQ14 hücresine eşit
olan satırlarının Sayfa5 A2 hücresinden itibaren DEĞER olarak yapıştırılmak istendiğini anlıyorum.
(Sayfa5'te 2'nci satırdan itibarenki alanda veri var mıdır, varsa A2 yerine ilk boş satıra mı yapıştıralacak bu da net değil)

Sayfa1 isimli sayfadaki hangi sütun aralığının kopyalanmak istendiğini anlayamadım ve A:AZ sütun aralığının istenildiğini varsaydım.

Aşağıdaki kod ile sonuç alamazsanız gerçek belgenizin özel bilgi içermeyen ve az satırlı bir örneğini yüklerseniz daha iyi olur.
Örnek belge yükleme yöntemine ilişkin kısa açıklama cevabın altındaki İMZA bölümünde var.

Aşağıdaki kod blokunu boş bir MODUL'e yapıştırıp çalıştırın, işlemin çok kısa süreceğini düşünüyorum.
.

[B][COLOR="blue"]Sub BARAN_FILTRE_KOPYA()[/COLOR][/B]
Set s1 = Sheets("Sayfa1"): Set s5 = Sheets("Sayfa5")

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
On Error Resume Next
s1.AutoFilterMode = False
s1.ShowAllData
s1son = s1.Cells(Rows.Count, 1).End(3).Row
s1.Columns("BA:BA").Insert Shift:=xlToRight

With s1.Range("BA2:BA" & s1son)
    .Formula = "=1*OR(F2>=500000,G2>=[B]Sayfa6!$AQ$14[/B],I2>=[B]Sayfa6!$AQ$14[/B])"
    .Value = .Value
End With

s1.Range("A1:BA1").AutoFilter Field:=53, Criteria1:="1"
s1.Range("A2:[B][COLOR="red"][SIZE="4"]AZ[/SIZE][/COLOR][/B]" & s1son).SpecialCells(xlCellTypeVisible).Copy
s5.[A2].PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
s1.Range("A1:BA1").AutoFilter Field:=53
s1.Columns("BA:BA").Delete Shift:=xlToLeft
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI.", vbInformation, "..:: Ömer BARAN ::.."

[B][COLOR="Blue"]End Sub[/COLOR][/B]

 

[Abdilaka]

Merhaba.

Örnek belge olmadığından ister istemez varsayımlarda bulunmak gerekiyor.

Verdiğiniz kod'da sayfa döngüsü göremedim.

Kod'da Sayfa1 isimli sayfanın;
-- F sütunundaki değer 500.000'den büyük veya eşit YA DA
-- G sütunu Sayfa6 isimli sayfanın AQ14 hücresine eşit YA DA
-- I sütunu Sayfa6 isimli sayfanın AQ14 hücresine eşit
olan satırlarının Sayfa5 A2 hücresinden itibaren DEĞER olarak yapıştırılmak istendiğini anlıyorum.
(Sayfa5'te 2'nci satırdan itibarenki alanda veri var mıdır, varsa A2 yerine ilk boş satıra mı yapıştıralacak bu da net değil)

Sayfa1 isimli sayfadaki hangi sütun aralığının kopyalanmak istendiğini anlayamadım ve A:AZ sütun aralığının istenildiğini varsaydım.

Aşağıdaki kod ile sonuç alamazsanız gerçek belgenizin özel bilgi içermeyen ve az satırlı bir örneğini yüklerseniz daha iyi olur.
Örnek belge yükleme yöntemine ilişkin kısa açıklama cevabın altındaki İMZA bölümünde var.

Aşağıdaki kod blokunu boş bir MODUL'e yapıştırıp çalıştırın, işlemin çok kısa süreceğini düşünüyorum.
.

[B][COLOR="blue"]Sub BARAN_FILTRE_KOPYA()[/COLOR][/B]
Set s1 = Sheets("Sayfa1"): Set s5 = Sheets("Sayfa5")

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
On Error Resume Next
s1.AutoFilterMode = False
s1.ShowAllData
s1son = s1.Cells(Rows.Count, 1).End(3).Row
s1.Columns("BA:BA").Insert Shift:=xlToRight

With s1.Range("BA2:BA" & s1son)
    .Formula = "=1*OR(F2>=500000,G2>=[B]Sayfa6!$AQ$14[/B],I2>=[B]Sayfa6!$AQ$14[/B])"
    .Value = .Value
End With

s1.Range("A1:BA1").AutoFilter Field:=53, Criteria1:="1"
s1.Range("A2:[B][COLOR="red"][SIZE="4"]AZ[/SIZE][/COLOR][/B]" & s1son).SpecialCells(xlCellTypeVisible).Copy
s5.[A2].PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
s1.Range("A1:BA1").AutoFilter Field:=53
s1.Columns("BA:BA").Delete Shift:=xlToLeft
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI.", vbInformation, "..:: Ömer BARAN ::.."

[B][COLOR="Blue"]End Sub[/COLOR][/B]

Öncelikle teşekkür ederim gerçekten inanılmaz hızlı bir şekilde çalıştı 130 bin satırı 3-4 saniyede çekti.

Varsayımlarınız doğru.

Yapıştırılacak sayfa boş her seferinde sıfırdan ayrılıyor. Sadece ilk satır dolu başlıklar vs var. Değer olarak yapıştırılmak istendiği doğrudur formul vs yok. Sayfa döngüsünden neyi kast ettiğinizi anlamadım for each ile satırlar sayılıp tek tek kontrol edilip uygunsa satırı kopyala yapıştır şeklinde çalışıyordu.

Örnek bir dosya ekledim.

http://s7.dosya.tc/server4/mznvvk/Segment.rar.html


Kısaca bilgi aktarayım.


230 bin satırlık data var K sütununa kadar. Bunları 5 gruba ayırıyoruz çeşitlik kriterlere göre burda makro ile çalışıyoruz ama data çoğaldıkça saati aşmaya başladı işlem.

Şöyle ki F,G ve I sütununda rakamsal değer ve B sütununda yazı var. Kriterlerde bunları sorgulatıyoruz. Konuda ilk verdiğim örnek tek bir ayrım(segment) içindi daha karmaşık kriterlerde var örneğin bir segmentin kriterleri şunlar:

Satırın;

- F değeri 500.000 den küçük 100.000 den büyük ve G hücresi (s6'da tanımlı sayfadaki) AQ14 'den küçük ve I hücresi yine AQ14'den küçük

ya da

- F değeri 100.000 ile 0 arasında ve G değeri < AQ14 ve G değeri > AP14 ve I değeri < AQ14

ya da

- F değeri 100.000 ile 0 arasında ve I değeri < AQ14 ve I değeri > AP14 ve G değeri < AQ14

Şu kodlar ile çalışıyor ama 5-6 dk sürüyor.

Şimdi müsait olursanız 2 sorum var.
1. Bu şekilde and or çok olan bir koşul sizin eklediğiniz kodda nasıl yazılabilir?
2. Taranıp kopyalanacak satırın şartlarına "satırın c sütunu hücresi 'kapalı' ya eşit değilse" nasıl eklenebilir? If de ekleyebiliyorum ama sizin verdiğinizle de mümkün mü bu?


Şimdiden teşekkürler.

 Sub Segment3()

    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim s3 As Worksheet
    Dim s4 As Worksheet
    Dim s5 As Worksheet
    Dim s6 As Worksheet

    Dim bul As Range
    
    Dim satır As Long
  
    satır = 1

    Set s1 = Sheets("Tüm")
    Set s2 = Sheets("Segment1")
    Set s3 = Sheets("Segment2")
    Set s4 = Sheets("Segment3")
    Set s5 = Sheets("Segment4")
    Set s6 = Sheets("Segmentasyon")
    
    Application.ScreenUpdating = False
    
        
For Each bul In s1.Range("A2:A" & s1.Range("A650536").End(3).Row)
     
    If ((s1.Cells(bul.Row, "F").Value < 500000 And s1.Cells(bul.Row, "F").Value >= 100000 _
    And s1.Cells(bul.Row, "G").Value < s6.Range("AQ14").Value) And _
    s1.Cells(bul.Row, "I").Value < s6.Range("AQ14").Value) Or _
    ((s1.Cells(bul.Row, "F").Value < 100000 And s1.Cells(bul.Row, "F").Value >= 0 And _
    s1.Cells(bul.Row, "G").Value < s6.Range("AQ14").Value And s1.Cells(bul.Row, "G").Value >= s6.Range("AP14").Value) And _
    s1.Cells(bul.Row, "I").Value < s6.Range("AQ14").Value) Or _
    ((s1.Cells(bul.Row, "F").Value < 100000 And s1.Cells(bul.Row, "F").Value >= 0 And _
    s1.Cells(bul.Row, "I").Value < s6.Range("AQ14").Value And s1.Cells(bul.Row, "I").Value >= s6.Range("AP14").Value) And _
     s1.Cells(bul.Row, "G").Value < s6.Range("AQ14").Value) Then
         
         
         satır = satır + 1
    bul.EntireRow.Copy
    s4.Select
    Cells(satır, 1).PasteSpecial
      
      End If
      

   
    Next bul
    
    
    [A2].Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
   
    
End Sub

 

[Ömer BARAN]

Tekrar merhaba.

Öncelikle, yazdığınız cevaplarda gereksiz ALINTI yapılmasının forum sayfalarının düzenini bozduğu düşüncemi ileteyim.
Gerekmedikçe alıntı yapmayınız, alıntı yapıldığında ise; alıntılanan mesajın sadece gerekli kısımlarını bırakıp diğer kısımlarını siliniz.


Verdiğim kod'da kritik nokta aşağıdaki kısım (yeşil renklendirdiğim açıklamaları okuyunuz)
.

[COLOR="SeaGreen"]'Alttaki satır ile AZ-BA sütunu arasına yeni sütun ekleniyor.[/COLOR]
s1.Columns("BA:BA").Insert Shift:=xlToRight

[COLOR="seagreen"]'Aşağıdaki dört satır ile YENİ BA sütununa koşul formülü uygulanıp, sonuçları DEĞER'e dönüştürülüyor.[/COLOR]
With s1.Range("BA2:BA" & s1son)
    .Formula = "[B][COLOR="Red"]=1*OR(F2>=500000,G2>=Sayfa6!$AQ$14,I2>=Sayfa6!$AQ$14)[/COLOR][/B]"
    .Value = .Value
End With
[COLOR="seagreen"]'Aşağıdaki satır ile, üstteki formülün sonucu 1 olan satırlar filtreleniyor.[/COLOR]
s1.Range("A1:BA1").AutoFilter Field:=53, Criteria1:="1"
[COLOR="seagreen"]'Aşağıdaki satır ile, [B]sadece[/B] filtre sonucunda kalan satırlar kopyalanıyor.[/COLOR]
s1.Range("A2:AZ" & s1son).SpecialCells(xlCellTypeVisible).Copy

[COLOR="seagreen"]'Sonraki kod kısımları ise kopyalananı yapıştır-eklenen BA sütunun sil işlemleri.[/COLOR]

Özetle işlem, satır satır döngüye girilmeden yapıldığından hız da makul seviyeye düşüyor.

İlk satırda başlıklar olduğuna göre BA2 hücresine,
VE/YADA işlevleriyle basit koşul formülünü kendiniz de kod'un içerisine dahil edebilirsiniz.
Formülü önce uygun bir hücreye uygulayıp koşula uyan satırlar için 1 değerini verdiğinden emin olun, ardından kod'un içerisine dahil edersiniz.

Verdiğim kod'daki koşul formülü kırmızı renklendirdiğim kısım.


Son cevabınızda belirttiğiniz koşullara ilişkin formül aşağıdaki gibi oluyor.
Aşağıdaki kod'u yukarıda kırmızı renklendirdiğim kısımın yerine yapıştırırsanız istediğiniz işlemin,
aynı şekilde birkaç saniyede tamamlanması gerekir.
.

=1*OR(AND(F2<500000,F2>=100000,G2<Sayfa6!$AQ$14,I2<Sayfa6!$AQ$14)," & _
      "AND(F2<100000,F2>=0,G2<Sayfa6!$AQ$14,G2>=Sayfa6!$AP$14,I2<Sayfa6!$AQ$14)," & _
      "AND(F2<100000,F2>=0,I2>=Sayfa6!$AP$14,I2<Sayfa6!$AQ$14,G2<Sayfa6!$AQ$14))

[B][COLOR="Red"]NOTLAR:[/COLOR]
-- [/B]C sütunu [COLOR="Red"]"kapalı"dan farklı[/COLOR] olma koşulu yukarıdaki işlem için, her durumda geçerli bir koşulsa;
gördüğünüz [B]her[/B]   [B][COLOR="Red"]AND([/COLOR][/B]   kısmını  [B][COLOR="Blue"] AND(C2<>""kapalı"",[/COLOR][/B]   olarak değiştirin.
[B]--[/B] EŞİTTİR işaretlerini verdiğiniz kod'a göre ekledim, cevabınızdaki cümlelerde EŞİTLİK durumu YOK.

.

 

[Abdilaka]

Teşekkürler formul çalışıyor karmaşık kriterlerde dahi çalıştı.

 

[Ömer BARAN]

Kriterleri yazarken birlikte aranacak koşulları, aynı AND parantezi içerisine yazmanız yeterli olur.
.

 

[Abdilaka]

Evet dediğiniz gibi iç içe and ve or ile herhangi bir problem olmadı. Çok teşekkürler. Son olarak verdiğiniz kodlarda makro içindeki formülde kapalı çalışma kitabı için düşeyara kullanılabilir mi?

Şunun gibi bir şeyde hata vermiyor ama çalıştırdığımda bir pencere açılıyor güncelleştirmek istediğiniz dosyayı seçin diye.

"=1*OR(VLOOKUP($A2,[Önceki.xlsx]Sayfa4!$A:$A,1,0))"

 

[Ömer BARAN]

Son cevabınızda kullandığınz formülün aslı tam olarak nasıldır acaba?
Formülde; aranan => A2 hücresi, arama alanı ...Belgesi Sayfa4 A:A sütunu, sütun indis sayısı 1.

Benim bu formülden anladığım anlamsız bir formül olduğudur.

Bir değeri başka bir sayfa A sütununda arayıp sütun indis sayısını 1 olarak kullandığınızda,
aranan değer ilgili sayfa A sütununda varsa aranan değer aynı zamanda formülün sonucudur, yoksa HATA sonucunu verir.

Önerim şöyle; gerçek belgenizin/belgelerinizin az satırlı küçük boyutlu birer kopyasını ekleyin,
yapılacak işlemi ve sonuçta elde edilmesi gereken sonucu ve bu sonuca nasıl ulaştığınızı net şekilde (sayfa adı, hücre adresi belirterek) açıklayın.

Formülü oluşturabiliyorsanız, istenilen sonucu veren formülü belgeye uygulayın ve onun üzerinden gidilsin.

Yani; gerçek formülü hücreye uygulayın, bu formülü makro koduna dahil etmek için destek isteyin.
.