sayfalar arası arabul kopyala yapıştır

[masue]

Sub ara()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim BUL As Range, Adres As String, Satir As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set S3 = Sheets("Sayfa3")

S3.Cells.Delete
Satir = 1
For i = 1 To S2.Range("A1048576").End(xlUp).Row

Set BUL = S1.Cells.Find(S2.Range("a" & i).Value, , , xlWhole)
If Not BUL Is Nothing Then
Adres = BUL.Address
Do
BUL.EntireRow.Copy S3.Cells(Satir, 1)
Satir = Satir + 1
Set BUL = S1.Cells.FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> Adres
S3.Select
Else
MsgBox "Aranan kayıt bulunamadı!", vbCritical
End If
Next
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Değerli arkadaşlar;
sayfalar arası kopyala yapıştır için arkadasların yardımıyla bir kod oluşturduk.şuan için %80 çalışmakda.bir kaç revizyon yapılması gerekiyor.yardımcı olacak arkadaşlara şimdiden teşekkür ederim.


sayfa2 ye yazdığım veriyi sayfa birde arayıp sayfa3'e tüm satır olarak yapıştırmaktayım.eksik olan.sayfa2 ye yazdığım kodları a2 den beri alt alta yazıyorum,arama butonuyla aramayı yapıyorum fakat sayfa2 ye girdiğim veriler sıralı veriler.kodu sayfa1 de bulamazsa sıra bozulmadan bulamadığını sayfa3'de boş satır olarak geçmesini istiyorum.

yardımcı olabilirseniz çok teşekkür ederim.iyi çalışmlar

birde kopyala yapıştır işlem çok uzun sürüyor."süz" gibi başka bir komutla daha hızlı işlem yapabilirmiyim.

örnek dosyamı paylaşıyorum

https://www.dosyaupload.com/5lm0

 

[Korhan Ayhan]

Sayfanızda başlık bilgisi var mı? Eğer varsa kodlar daha da hızlı çalışabilir.

 

[masue]

sayfanızda başlık bilgisi var mı? Eğer varsa kodlar daha da hızlı çalışabilir.

hocam a1 satırında başlıklar var.hocam aslında sayfanın tümünde arama yapması değilde sayfa1 de k ile cd sütünu arasında arama yapmasını istiyorum.birde dediğim gibi bulamadığını 3 sayfada ilgili satırı boş bıraksın istiyorum.ilgi ve alakanız için teşekkür ederim.iyi çalışmlar

 

[masue]

sayfa2 ye yazdığım veriyi sayfa birde arayıp sayfa3'e tüm satır olarak yapıştırmaktayım.eksik olan.sayfa2 ye yazdığım kodları a2 den beri alt alta yazıyorum,arama butonuyla aramayı yapıyorum fakat sayfa2 ye girdiğim veriler sıralı veriler.kodu sayfa1 de bulamazsa sıra bozulmadan bulamadığını sayfa3'de boş satır olarak geçmesini istiyorum.

 

[Korhan Ayhan]

"Sayfa1" isimli sayfanızda başlık satırı olduğunu varsaydım.

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub ARA()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Bul As Range, Adres As String, Satir As Long, X As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    S3.Cells.Delete
    Satir = 1
    
    For X = 1 To S2.Range("A1048576").End(xlUp).Row
        If S2.Cells(X, 1) <> "" Then
            If WorksheetFunction.CountIf(S1.Range("I:CD"), S2.Cells(X, 1)) > 0 Then
                Set Bul = S1.Range("I:CD").Find(S2.Cells(X, 1), , , xlWhole)
                If Not Bul Is Nothing Then
                    S1.Range("$A$1:$KS$" & S1.Rows.Count).AutoFilter Field:=Bul.Column, Criteria1:=S2.Cells(X, 1)
                    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
                    If Son > 1 Then
                        S1.Range("A2:A" & Son).EntireRow.Copy S3.Cells(Satir, 1)
                        Satir = S3.Cells(S3.Rows.Count, 2).End(3).Row + 1
                    Else
                        Satir = Satir + 1
                    End If
                    S1.ShowAllData
                End If
            Else
                Satir = Satir + 1
            End If
        End If
    Next
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Arama işlemi tamamlanmıştır.", vbInformation
End Sub

 

[masue]

Sub ARA()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim Bul As Range, Adres As String, Satir As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set S3 = Sheets("Sayfa3")

S3.Cells.Delete
Satir = 1

For X = 1 To S2.Range("A1048576").End(xlUp).Row
If S2.Cells(X, 1) <> "" Then
S1.Range("$A$1:$KS$" & S1.Rows.Count).AutoFilter Field:=11, Criteria1:=S2.Cells(X, 1)
Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
If Son > 1 Then
S1.Range("A2:A" & Son).EntireRow.Copy S3.Cells(Satir, 1)
Satir = S3.Cells(S3.Rows.Count, 2).End(3).Row + 1
Else
Satir = Satir + 1
End If
End If
Next

On Error Resume Next
S1.ShowAllData
On Error GoTo 0

Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "Arama işlemi tamamlanmıştır.", vbInformation
End Sub

hocam 3.sayfaya arama sonucunu atmıyor.sadece k sütunundakileri kırmızıyla gösterdiğim 11 sütunda arama yapıyor.

son gönderdiğiniz kodları uyguladığım dosyamı ekliyorum.hocam yüzdük yüzdük kuyruğuna geldik.Yardımlarınız için teşekkür eder iyi çalışmalar dilerim.

https://www.dosyaupload.com/9xS9

 

[masue]

hocam 3.sayfaya arama sonucunu atmıyor.sadece k sütunundakileri kırmızıyla gösterdiğim 11 sütunda arama yapıyor."I" sütunuyla "CD"sütunu arasında yapmalı.

son gönderdiğiniz kodları uyguladığım dosyamı ekliyorum.hocam yüzdük yüzdük kuyruğuna geldik.Yardımlarınız için teşekkür eder iyi çalışmalar dilerim.

https://www.dosyaupload.com/9xS9

 

[Korhan Ayhan]

Üstteki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[masue]

Teşekkrüler hocam saolun