Benzersiz ve Formülsüz Kopyala

[meslek5]

Değerli üstatlar daha önce Korhan hocamın paylaştığı bir makro kodunu kendi çalışmama uyarlamaya çalışıyorum fakat kopyalamayı formül ile birlikte yapıyor.
Aşağıdaki kod üzerinde nasıl bir değişiklik yapmalıyım ki sadece değerleri kopyalasın. Şimdiden teşekkür ederim.

Yapılmak İstenilen İşlem; Sayfa1'in C9:C208 arasındaki benzersiz verileri (sadece değerleri) Sayfa2'nin D11 hücresine yapıştırmak

On Error Resume Next
Application.ScreenUpdating = False
Sheets("Sayfa1").Range("C9:C" & Sheets("Sayfa1").Cells(Rows.Count, 3).End(3).Row).Copy Range("D11")
Range("D11: D" & Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
Application.ScreenUpdating = True

 

[tugkan]

Deneyip sonucu paylaşır mısınız?

Bu kodu sadece değerleri kopyalayacak şekilde uyarlamak için, .Copy metodundan sonra PasteSpecial kullanarak sadece değerlerin yapıştırılmasını sağlayabilirsiniz. Ayrıca, hedef aralıktaki verileri yapıştırmadan önce temizlemeniz daha sağlıklı olacaktır. Aşağıdaki gibi bir düzenleme yapabilirsiniz:

On Error Resume Next
Application.ScreenUpdating = False

' Sayfa1'deki C9:C208 arasındaki benzersiz verileri al
With Sheets("Sayfa1")
    .Range("C9:C" & .Cells(Rows.Count, 3).End(3).Row).Copy
End With

' Sayfa2'de D11 hücresine sadece değerleri yapıştır
With Sheets("Sayfa2")
    .Range("D11:D" & .Cells(Rows.Count, 4).End(3).Row).ClearContents ' Önce hedef alanı temizle
    .Range("D11").PasteSpecial Paste:=xlPasteValues ' Sadece değerleri yapıştır
End With

' Yapıştırılan verilerdeki tekrar eden değerleri kaldır
Sheets("Sayfa2").Range("D11:D" & Sheets("Sayfa2").Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo

Application.CutCopyMode = False
Application.ScreenUpdating = True

Bu kodda şu değişiklikler yapıldı:

• PasteSpecial Paste:=xlPasteValues kullanılarak sadece değerlerin yapıştırılması sağlandı.
• Hedef alan olan D11 aralığına yapıştırma işlemi öncesinde ClearContents ile temizleme yapılıyor.
• Kopyalama sonrası Excel'in kopyalama modunu kapatmak için Application.CutCopyMode = False eklendi.

Bu haliyle formüller yerine sadece değerler Sayfa2'ye kopyalanacaktır.

 

[meslek5]

Deneyip sonucu paylaşır mısınız?

Bu kodu sadece değerleri kopyalayacak şekilde uyarlamak için, .Copy metodundan sonra PasteSpecial kullanarak sadece değerlerin yapıştırılmasını sağlayabilirsiniz. Ayrıca, hedef aralıktaki verileri yapıştırmadan önce temizlemeniz daha sağlıklı olacaktır. Aşağıdaki gibi bir düzenleme yapabilirsiniz:

On Error Resume Next
Application.ScreenUpdating = False

' Sayfa1'deki C9:C208 arasındaki benzersiz verileri al
With Sheets("Sayfa1")
    .Range("C9:C" & .Cells(Rows.Count, 3).End(3).Row).Copy
End With

' Sayfa2'de D11 hücresine sadece değerleri yapıştır
With Sheets("Sayfa2")
    .Range("D11:D" & .Cells(Rows.Count, 4).End(3).Row).ClearContents ' Önce hedef alanı temizle
    .Range("D11").PasteSpecial Paste:=xlPasteValues ' Sadece değerleri yapıştır
End With

' Yapıştırılan verilerdeki tekrar eden değerleri kaldır
Sheets("Sayfa2").Range("D11:D" & Sheets("Sayfa2").Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo

Application.CutCopyMode = False
Application.ScreenUpdating = True

Bu kodda şu değişiklikler yapıldı:

• PasteSpecial Paste:=xlPasteValues kullanılarak sadece değerlerin yapıştırılması sağlandı.
• Hedef alan olan D11 aralığına yapıştırma işlemi öncesinde ClearContents ile temizleme yapılıyor.
• Kopyalama sonrası Excel'in kopyalama modunu kapatmak için Application.CutCopyMode = False eklendi.

Bu haliyle formüller yerine sadece değerler Sayfa2'ye kopyalanacaktır.

hocam çok teşekkür ederim ama hiçbir kopyalama yapmadı.

 

[pitchoute]

Deneyip sonucu paylaşabilir misiniz;

Sub KopyalaSadeceDegerler()
    On Error Resume Next
    Application.ScreenUpdating = False
    
    Dim kaynakSayfa As Worksheet
    Dim hedefSayfa As Worksheet
    Dim kaynakAralik As Range
    Dim hedefHücre As Range
    Dim sonSatir As Long
    
    Set kaynakSayfa = ThisWorkbook.Sheets("Sayfa1")
    Set hedefSayfa = ThisWorkbook.Sheets("Sayfa2") 
    
    sonSatir = kaynakSayfa.Cells(kaynakSayfa.Rows.Count, 3).End(xlUp).Row
    
    Set kaynakAralik = kaynakSayfa.Range("C9:C" & sonSatir)
    
    Set hedefHücre = hedefSayfa.Range("D11")
    
    hedefHücre.Resize(kaynakAralik.Rows.Count, 1).Value = kaynakAralik.Value
    
    With hedefSayfa
        .Range("D11:D" & .Cells(.Rows.Count, 4).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
    End With
    
    Application.ScreenUpdating = True
    MsgBox "Sadece değerler başarıyla kopyalandı ve benzersiz veriler yapıştırıldı.", vbInformation
End Sub

 

[meslek5]

Deneyip sonucu paylaşabilir misiniz;

Sub KopyalaSadeceDegerler()
    On Error Resume Next
    Application.ScreenUpdating = False
   
    Dim kaynakSayfa As Worksheet
    Dim hedefSayfa As Worksheet
    Dim kaynakAralik As Range
    Dim hedefHücre As Range
    Dim sonSatir As Long
   
    Set kaynakSayfa = ThisWorkbook.Sheets("Sayfa1")
    Set hedefSayfa = ThisWorkbook.Sheets("Sayfa2")
   
    sonSatir = kaynakSayfa.Cells(kaynakSayfa.Rows.Count, 3).End(xlUp).Row
   
    Set kaynakAralik = kaynakSayfa.Range("C9:C" & sonSatir)
   
    Set hedefHücre = hedefSayfa.Range("D11")
   
    hedefHücre.Resize(kaynakAralik.Rows.Count, 1).Value = kaynakAralik.Value
   
    With hedefSayfa
        .Range("D11:D" & .Cells(.Rows.Count, 4).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
    End With
   
    Application.ScreenUpdating = True
    MsgBox "Sadece değerler başarıyla kopyalandı ve benzersiz veriler yapıştırıldı.", vbInformation
End Sub

Çok çok teşekkür ederim hocam. Tam istediğim gibi hızlı çalışıyor.

 

[pitchoute]

Rica ederim hocam, iyi çalışmalar