sayfadan diğer sayfaya aktarma

[unutkan]

bu nasıl yapılabilir

ekli dosyada açıklamalı olarak belirtiğim gibi işlemin yapılması mümkünmüdür.
şimdiden teşekkürler.

 

[Orion1]

Dosyanız ektedir.

Sub aktar()
Dim sh As Worksheet, sat As Long, sat2 As Long, i As Long, k As Range
Set sh = Sheets("Sayfa2")
Sheets("Sayfa1").Select
sat = Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = False
sh.Range("A2:b65536").ClearContents
sat2 = 2
For i = 5 To sat
    If WorksheetFunction.CountIf(Range("B5:B" & i), Cells(i, "B").Value) = 1 Then
        sh.Cells(sat2, "A").Value = Cells(i, "A").Value
        sh.Cells(sat2, "B").Value = Cells(i, "B").Value
        sat2 = sat2 + 1
    End If
Next i
sh.Select
Application.ScreenUpdating = True
MsgBox "Veriler sayfa2'ye benzersiz akatarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
            

End Sub

 

[unutkan]

yardımınız için teşekkürler syn. evren gizlen

 

[unutkan]

Dosyanız ektedir.

Sub aktar()
Dim sh As Worksheet, sat As Long, sat2 As Long, i As Long, k As Range
Set sh = Sheets("Sayfa2")
Sheets("Sayfa1").Select
sat = Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = False
sh.Range("A2:b65536").ClearContents
sat2 = 2
For i = 5 To sat
    If WorksheetFunction.CountIf(Range("B5:B" & i), Cells(i, "B").Value) = 1 Then
        sh.Cells(sat2, "A").Value = Cells(i, "A").Value
        sh.Cells(sat2, "B").Value = Cells(i, "B").Value
        sat2 = sat2 + 1
    End If
Next i
sh.Select
Application.ScreenUpdating = True
MsgBox "Veriler sayfa2'ye benzersiz akatarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
            

End Sub

bu aktarma kısmında problem yok ama diğer sarı hücreye kadar yazılan eğer formülü sayfada veriler çoğaldıkça çok yavaş işlem yapıyor. acaba vba da yapılması mümkünmüdür bu işlemin. Teşekkürler