Aynı Değerleri Bulma ve Farklı Sayfada Saydırma,

Katılım
9 Haziran 2019
Mesajlar
108
Beğeniler
11
Excel Vers. ve Dili
Office 2016 Eng.
#1
Merhaba;

Ekteki excel çalışmasında başlıkta belirtiğim şekilde Aynı değerleri bulmasını B sütunundaki Satırlara "Mevcut" yazmasını, A sütununda verilerden kaç adet mevcut ise Rapor sayfasında saydırmak istiyorum.

Normalde formül ve Pivottable ile işlemi tamamlıyorum. Makro öğrenmek ve yaptığım işlemi kısa yoldan tamamlamak istiyorum. Siz değerli excel kullanıcıların yardımlarını talep ediyorum. Teşekkür ederim.


Örnek Dosya;Aynı Değerleri Bulma ve Farklı Sayfada Saydırma,
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
24,639
Beğeniler
427
Excel Vers. ve Dili
OFFICE 2019 PRO TR
#4
Alternatif;

Kod:
Option Explicit

Sub Yaz_Aktar()
    Dim S1 As Worksheet, Son As Long, S2 As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sheet1")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    S1.Range("B2:B" & S1.Rows.Count).ClearContents
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    With S1.Range("B2:B" & Son)
        .Formula = "=IF(COUNTIF(Sheet2!A:A,A2)>0,""Mevcut"","""")"
        .Value = .Value
    End With

    S1.Range("A1:B" & S1.Rows.Count).AutoFilter Field:=2, Criteria1:="<>"

    On Error Resume Next
    Set S2 = Sheets("Rapor")
    On Error GoTo 0
    
    If S2 Is Nothing Then
        Sheets.Add , Sheets(Sheets.Count)
        Set S2 = ActiveSheet
        S2.Name = "Rapor"
    End If

    S2.Range("A:B").Clear
    S1.Columns("A:A").SpecialCells(xlCellTypeVisible).Copy S2.Range("A1")
    S2.Range("$A$1:$A$" & S2.Rows.Count).RemoveDuplicates Columns:=1, Header:=xlYes
    S2.Range("B1").FillRight
    S2.Range("B1") = "Adet"
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    
    With S2.Range("B2:B" & Son)
        .Formula = "=COUNTIF(Sheet2!A:A,A2)"
        .Value = .Value
    End With
    
    S2.Columns.AutoFit
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Set S1 = Nothing
    Set S2 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Katılım
9 Haziran 2019
Mesajlar
108
Beğeniler
11
Excel Vers. ve Dili
Office 2016 Eng.
#5
Sn. @Korhan Ayhan Bey ilginiz ve alternatif sunmuş olduğunuz kodlar için teşekkür ederim. İyi günler.
 
Üst