sayfalar arasındaki aynı sayıyı bulma

Katılım
16 Eylül 2018
Mesajlar
21
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-09-2019
çalışma kitabı içerisinde sayfalar arasında aynı yazılmış veriyi olan veriyi nasıl bulabilirim? ctrl f ile çalışma kitabında aradığımda bulabiliyorum ama çok veri var ve zaman isteyen bir iş? iki sayfadaki d sütünunda yazılmış aynı olan veriyi nasıl bulabilirim. diğer bir sayfaya nasıl taşırım?
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Eklediğiniz dosyada "AHMET" sayfasında 4 adet ALİ var, MEHMET sayfasında 5 adet ALİ var. Bu durumda eşleştirmenin nasıl yapılmasını istiyorsunuz?

Daha kısaca özetlersek 3. sayfada görmek istediğiniz sonucu elle yazabilir misiniz?
 
Katılım
16 Eylül 2018
Mesajlar
21
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-09-2019
tekrar edeni sadece bir kez bulunsun 3. sütunda. mümkün müdür acaba?
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Kod:
Option Explicit

Sub D_SUTUNU_ORTAK_OLANLAR()
    Dim Sayfa As Worksheet, S1 As Worksheet, S2 As Worksheet, Zaman As Double
    Dim Son As Long, X As Integer, Y As Integer, Liste As Object
    
    Zaman = Timer
    
    Set S1 = Sheets("D SÜTÜNU ORTAK")
    
    Set Liste = CreateObject("Scripting.Dictionary")
    Liste.CompareMode = 1
    
    S1.Range("D4:D" & Rows.Count).ClearContents
    
    For Each Sayfa In ThisWorkbook.Worksheets
        Son = Sayfa.Cells(Rows.Count, 4).End(3).Row
        For X = 8 To Son
            For Y = 1 To Sheets.Count
                Set S2 = Sheets(Y)
                Select Case S2.Name
                    Case S1.Name, Sayfa.Name
                    Case Else
                    If WorksheetFunction.CountIf(S2.Range("D:D"), Sayfa.Cells(X, "D").Value) > 0 Then
                        If Not Liste.Exists(Sayfa.Cells(X, "D").Value) Then
                            Liste.Add Sayfa.Cells(X, "D").Value, Nothing
                        End If
                    End If
                End Select
            Next
        Next
    Next
    
    S1.Range("D4").Resize(Liste.Count) = Application.Transpose(Liste.Keys)
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Katılım
16 Eylül 2018
Mesajlar
21
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-09-2019
Option Explicit Sub D_SUTUNU_ORTAK_OLANLAR() Dim Sayfa As Worksheet, S1 As Worksheet, S2 As Worksheet, Zaman As Double Dim Son As Long, X As Integer, Y As Integer, Liste As Object Zaman = Timer Set S1 = Sheets("D SÜTÜNU ORTAK") Set Liste = CreateObject("Scripting.Dictionary") Liste.CompareMode = 1 S1.Range("D4:D" & Rows.Count).ClearContents For Each Sayfa In ThisWorkbook.Worksheets Son = Sayfa.Cells(Rows.Count, 4).End(3).Row For X = 8 To Son For Y = 1 To Sheets.Count Set S2 = Sheets(Y) Select Case S2.Name Case S1.Name, Sayfa.Name Case Else If WorksheetFunction.CountIf(S2.Range("D:D"), Sayfa.Cells(X, "D").Value) > 0 Then If Not Liste.Exists(Sayfa.Cells(X, "D").Value) Then Liste.Add Sayfa.Cells(X, "D").Value, Nothing End If End If End Select Next Next Next S1.Range("D4").Resize(Liste.Count) = Application.Transpose(Liste.Keys) MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _ "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation End Sub
BECEREMEDİM SANIRIM
 
Üst