1.Sayfanın Eşleşen Değerlerini, 2.Sayfadan Ayırmak

[EKREM1661]

Çok değerli arkadaşlar..! Ekte verilen dosyada, 1.nci sayfada yer alan tablo verileri, 2.nci sayfa içerisine karışmış.. Şimdi bu karışan verileri kaldırmamız veya başka sayfaya ayırmamız lazım.. Yani iki sayfayı (D sütunlarındaki numaraları) eşleştirilerek, eşleşen numaralı satırlar 2.nci sayfadan ayrılacak.. Ölçüt D sütunu olacak.. Yardımcı olmanız çok makbule geçecek.. Veriler çok olduğundan tek tek çok zor olacak..

 

[GAZOZ_55]

Dosyanız ektedir.

 

[EKREM1661]

Dosyada kod falan göremedim.. Acaba bende mi bir sorun..

 

[GAZOZ_55]

Özür dilerim, konunun Makro-VBA Soruları başlığı altında açıldığını görmemişim. Kod olarak bakayım.

 

[GAZOZ_55]

Merhaba hocam, dosyanız ektedir.

Sub sil()
Application.ScreenUpdating = False
son1 = Sayfa1.Cells(Rows.Count, 4).End(xlUp).Row
son2 = Sayfa3.Cells(Rows.Count, 4).End(xlUp).Row
On Error Resume Next
For i = 2 To son2
Sayfa3.Range("AE" & i).Value = WorksheetFunction.VLookup(Sayfa3.Range("D" & i).Value, Sayfa1.Range("D2" & son1), 1, 0)
Next i
For i = 1 To son2
If Sayfa3.Range("AE" & i).Value <> "" Then
Sayfa3.Range("AE" & i).EntireRow.ClearContents
End If
Next i
For a = 1 To Sheets.Count
sat = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Row
sut = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Column
For b = sat To 1 Step -1
If WorksheetFunction.CountA(Sheets(a).Rows(b)) = 0 Then Sheets(a).Rows(b).Delete
Next
For c = sut To 1 Step -1
If WorksheetFunction.CountA(Sheets(a).Columns(c)) = 0 Then Sheets(a).Columns(c).Delete
Next
Next
Application.ScreenUpdating = True
End Sub

 

[EKREM1661]

Üstadım, çalıştıramadım. Fakat kolaylaştırmak maksadıyla her iki sayfa verilerini D sütunu olarak birleştirdim. Dolayısıyla mükerrerler oluştu. Mükerrerlerin tamamını kaldırırsak aynı sonuca ulaşırız.. Sadece D sütunlarını bıraktığım örnek dosya ekledim.. (Açıklama dosyada)

 

[GAZOZ_55]

Merhaba hocam, dosyanız ektedir. Butona bastığınızda makro çalışacaktır. Makro 49 sn. sürmektedir.

Sub sil()
With Application
.Calculation = xlAutomatic
.ScreenUpdating = False
son = Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To son
Range("E" & i).Value = WorksheetFunction.CountIf(Range("D2" & son), Range("D" & i).Value)
Next i
son2 = Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To son2
If Range("E" & i) > 1 Then
Range("E" & i).EntireRow.ClearContents
End If
Next
Range("D").SpecialCells(xlCellTypeBlanks).Rows.Delete xlUp
Range("E:E").ClearContents
.Calculation = xlAutomatic
.ScreenUpdating = False
End With
End Sub

 

[Ömer BARAN]

Merhaba.
Umarım yanlış anlamadım.
Aşağıdaki şekilde işlem yapılırsa; Sayfa2 D sütunundaki satırlardan, D sütunundaki verilerden, Sayfa1 D sütununda da olan satırlar silinir.
For .... Next döngüsü yerine filtre'den yararlanarak işlem daha hızlı tamamlanacaktır.

Konu açılış mesajına eklenen örnek belgeye göre alternatif çözüm önerisinde bulunayım.
Alt taraftan Sayfa2'nin adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılacak VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırın.
VBA ekranında üstteki menü çubuğunda yer alan RUN düğmesine tıklayarak kod'u çalıştırın.

Sub MUKERRER_KALDIR()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If s2.AutoFilterMode = True Then s2.AutoFilterMode = False
    s2.Columns("AE:AE").Insert Shift:=xlToRight
    son1 = s1.Cells(Rows.Count, "D").End(3).Row
    son2 = s2.Cells(Rows.Count, "D").End(3).Row
    With s2.Range("AE2:AE" & son2)
        .Formula = "=COUNTIF(Sayfa1!D2:D" & son1 & ",D2)"
        .Calculate : .Value = .Value
    End With
s2.Range("A1:AE" & son2).AutoFilter Field:=31, Criteria1:=">0"
If s2.Cells(Rows.Count, 4).End(3).Row > 1 Then _
    s2.Range("A2:AE" & son2).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
s2.Columns("AE:AE").Delete Shift:=xlToLeft
If s2.AutoFilterMode = True Then s2.AutoFilterMode = False
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[Ziynettin]

Merhaba,
Bende hazırlamıştım. Alternatif olsun.

Option Explicit
Sub test()
Dim a(), b(), c(), d As Object
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim i As Long, say As Long, y As Byte
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2"): Set s3 = Sheets("Sayfa3")
Set d = CreateObject("scripting.dictionary")
    a = s1.Range("D2:D" & s1.Cells(Rows.Count, 4).End(3).Row).Value
    For i = 1 To UBound(a): d(a(i, 1)) = d(a(i, 1)) + 1: Next i
    b = s2.Range("A2:AC" & s2.Cells(Rows.Count, 4).End(3).Row).Value
    ReDim c(1 To UBound(b, 2), 1 To 1)
    For i = 1 To UBound(b)
        If d(b(i, 4)) < 1 Then
            say = say + 1
            ReDim Preserve c(1 To UBound(b, 2), 1 To say)
            For y = 1 To UBound(b, 2): c(y, say) = b(i, y): Next y
        End If
    Next i
    s3.Range("A2:AC" & Rows.Count).ClearContents
    If say > 0 Then
        s3.[A2].Resize(say, UBound(b, 2)) = Application.Transpose(c)
    End If
s3.Select
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Ömer BARAN]

Merhaba Sayın @Ziynettin .
Siz bana zorla scripting.dictionary yöntemini öğreteceksiniz anlaşılan !
Ama sözlü veya karşılıklı yazışarak iletişim olmazsa biraz zor benim için, yaşlılık herhalde.

 

[Ziynettin]

Merhaba Ömer Bey,

"scripting.dictionary" yöntemi forumda fazla kullanan yok. Temennim öğrenmenizden yana. Siz de farklı çözümler sunarak zenginlik katmış olursunuz.

Saygılar....

 

[EKREM1661]

Saygıdeğer arkadaşlar, her birinize (Ömer bey, ziynettin bey, GAZOZ_55) ayrı ayrı teşekkürler, hepsi de güzel olmuş..Elinize sağlık..

 

[igultekin2000]

Merhaba,
Bende hazırlamıştım. Alternatif olsun.

Option Explicit
Sub test()
Dim a(), b(), c(), d As Object
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim i As Long, say As Long, y As Byte
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2"): Set s3 = Sheets("Sayfa3")
Set d = CreateObject("scripting.dictionary")
    a = s1.Range("D2:D" & s1.Cells(Rows.Count, 4).End(3).Row).Value
    For i = 1 To UBound(a): d(a(i, 1)) = d(a(i, 1)) + 1: Next i
    b = s2.Range("A2:AC" & s2.Cells(Rows.Count, 4).End(3).Row).Value
    ReDim c(1 To UBound(b, 2), 1 To 1)
    For i = 1 To UBound(b)
        If d(b(i, 4)) < 1 Then
            say = say + 1
            ReDim Preserve c(1 To UBound(b, 2), 1 To say)
            For y = 1 To UBound(b, 2): c(y, say) = b(i, y): Next y
        End If
    Next i
    s3.Range("A2:AC" & Rows.Count).ClearContents
    If say > 0 Then
        s3.[A2].Resize(say, UBound(b, 2)) = Application.Transpose(c)
    End If
s3.Select
MsgBox "İşlem tamam.", vbInformation
End Sub

iyi günler; Kodun çalışması çok güzel, başka amaçla da kullanmak için eşleşmeyen değer varsa onları da başka bir çalışma sayfasına aktarsa değişik amaçla kullanma imkanı olur.

 

[Ziynettin]

Sayın igültekin2000;

Sayfa2'de olup sayfa1'de olmayanları başka sayfaya ("Sayfa3") aktarıyor. Ya da ne yapmak istediğinizi ben mi anlamadım.

 

[igultekin2000]

Sayın igültekin2000;

Sayfa 2' de olup Sayfa1 ' de yoksa kıyaslıyor. Sayfa1' de olup Sayfa2 ' de olmayınca da kıyaslaması şeklinde sordum ama sonradan aklıma geldi aynı kodun sayfa kısımlarını değiştirerek ikinci makro ile de ikinci kıyaslama yapmak aklıma geldi. , Teşekkürler