Verileri teke düşürerek diğer sayfaya aktarma

[Ahmet Sami]

Arkadaşlar aşağıdaki koda göre VERİ sayfasında bulunan yinelenen veriler teke düşürülerek ANASAYFAYA ya aktarıyorum ancak kod çok uzun olduğu için bilgisayarı yavaşlatıyor kodu kısaltmamız mümkünmüdür. Bu konuda yardımcı olursanız sevinirim şimdiden teşekkür ederim.

Option Explicit
Private Sub Worksheet_Activate()
Dim syf As Worksheet
For Each syf In Worksheets
On Error Resume Next
If syf.FilterMode = False Then
Else
syf.ShowAllData
End If
Next syf
Sheets("VERİ").Columns(2).Copy
Sheets("ANASAYFA").Columns("ab:ab").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$AB$1:$AB$65536").RemoveDuplicates Columns:=1, Header:= _
xlYes
ActiveWorkbook.Worksheets("ANASAYFA").Sort.SortFields.Add Key:=Range( _
"AB2:AB65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ANASAYFA").Sort
.SetRange Range("AB1:AB65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Sheets("VERİ").Columns(3).Copy
Sheets("ANASAYFA").Columns("ac:ac").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$AC$1:$AC$65536").RemoveDuplicates Columns:=1, Header:= _
xlYes
ActiveWorkbook.Worksheets("ANASAYFA").Sort.SortFields.Add Key:=Range( _
"AC2:AC65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ANASAYFA").Sort
.SetRange Range("AC1:AC65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Sheets("VERİ").Columns(4).Copy
Sheets("ANASAYFA").Columns("ad:ad").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$AD$1:$AD$65536").RemoveDuplicates Columns:=1, Header:= _
xlYes
ActiveWorkbook.Worksheets("ANASAYFA").Sort.SortFields.Add Key:=Range( _
"AD2:AD65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ANASAYFA").Sort
.SetRange Range("AD1:AD65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

 

[turist]

Sorunuzu kendi hazırladığınız bir "örnek" excel dosyası ekleyerek sorarsanız, daha hızlı ve doğru cevaplar bulabilirsiniz.
Örnek excel dosyası ekleme hakkında bilgi edinmek isterseniz:
https://www.excel.web.tr/threads/soru-ile-ilgili-oernek-excel-dosyasi-ekleme.174755/ bakınız

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodları deneyiniz.

Private Sub Worksheet_Activate()
    Dim syf As Worksheet
    For Each syf In Worksheets
        If syf.FilterMode Then syf.ShowAllData
    Next syf
    Application.EnableEvents = False
    Range("B:D").Copy
    With Worksheets("ANASAYFA")
        .Range("AB1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("AB:AB").RemoveDuplicates Columns:=1, Header:=xlYes
        .Range("AC:AC").RemoveDuplicates Columns:=1, Header:=xlYes
        .Range("AD:AD").RemoveDuplicates Columns:=1, Header:=xlYes
        With .Sort
            .SetRange Range("AD:AD")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    Application.EnableEvents = True
End Sub

 

[Ahmet Sami]

Yükledim yardımcı olursanız sevinirim

http://s7.dosya.tc/server11/k1kgql/Teke_Dusurerek_aktar.xls.html

 

[Ahmet Sami]

Sayın Dalgalikur uyguladım ancak hiçbir veriyi aktarmıyordu. Ancak Copy yapılacak olarak LİSTE sayfasını ekledim oldu. teşekkür ederim.