• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Yinelenenleri teke düşürme

  • Konbuyu başlatan Konbuyu başlatan aspava
  • Başlangıç tarihi Başlangıç tarihi
A

aspava

Altın Üye
Katılım
24 Nisan 2006
Mesajlar
241
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2016 TR 32 Bit
Merhaba ,

Örnek Dosyada yer alan dosyamda olan birden fazla yinelenen satırları teke düşürmek istiyorum . Sadece Gün sayısını tek seferde toplanmasını istiyorum. Yinelenenleri kaldır sekmesiyle yapabiliyorum ama gün sayısı toplamlarını aldıramıyorum hepsini tek seferde nasıl yapabilirim acaba. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.
 

Ekli dosyalar

yakamozexcel' Alıntı:
Kod: 
=ÇOKETOPLA(L2:L4;G2:G4;G11)
Genişletmek için tıkla ...
Merhaba yakamozexcel , Formülle yada yenilenleri kaldır ile yapabilirim ama birden fazla kez işlem yapmam gerekiyor. Ben tek seferde hem kişileri teke düşürüp hemde gün toplamlarını makro ile aldırmak istiyorum.
 
Merhaba.
Alternatif olsun.

M2 hücresine aşağıdaki formülü kopyalayıp aşağı doğru çoğaltın.
Kod: 
=ETOPLA($G$2:$G$100;G2;$L$2:$L$100)
M sütununu kopyalayıp değerleri yapıştırın.(Formülleri kaldırmak için)

Yinelenenleri kaldır işlemini yapın.
M sütunundaki değerleri L'ye kopyalayın.
 
Kod: 
Sub TC_Tek_Tablo()

    Dim wsK As Worksheet, wsH As Worksheet
    Dim sonSatir As Long, sonKolon As Long
    Dim i As Long, j As Long
    Dim dict As Object
    Dim TC As String
    Dim veri As Variant
    Dim satir As Long
    Dim toplamGun As Double
    
    Set wsK = ThisWorkbook.Sheets("Sayfa1")
    Set wsH = ThisWorkbook.Sheets("Sayfa2")
    
    wsH.Cells.Clear
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    sonSatir = wsK.Cells(wsK.Rows.Count, "G").End(xlUp).Row
    sonKolon = wsK.Cells(1, wsK.Columns.Count).End(xlToLeft).Column
    
    ' Başlıkları kopyala
    For j = 1 To sonKolon
        wsH.Cells(1, j).Value = wsK.Cells(1, j).Value
    Next j
    
    satir = 2
    
    For i = 2 To sonSatir
        
        TC = Trim(wsK.Cells(i, "G").Value)
        veri = wsK.Cells(i, "L").Value
        
        If IsNumeric(veri) Then
            gun = CDbl(veri)
        Else
            gun = 0
        End If
        
        If TC <> "" Then
            
            If dict.exists(TC) Then
                ' Gün Sayısını ekle
                wsH.Cells(dict(TC), "L").Value = wsH.Cells(dict(TC), "L").Value + gun
            
            Else
                ' Satırı komple kopyala
                For j = 1 To sonKolon
                    wsH.Cells(satir, j).Value = wsK.Cells(i, j).Value
                Next j
                
                ' Gün sayısını garanti numeric yaz
                wsH.Cells(satir, "L").Value = gun
                
                dict.Add TC, satir
                satir = satir + 1
            End If
            
        End If
        
    Next i
    
'    ' GENEL TOPLAM
'    toplamGun = 0
'
'    For i = 2 To satir - 1
'        If IsNumeric(wsH.Cells(i, "L").Value) Then
'            toplamGun = toplamGun + wsH.Cells(i, "L").Value
'        End If
'    Next i
'
'    wsH.Cells(satir, "K").Value = "GENEL TOPLAM"
'    wsH.Cells(satir, "L").Value = toplamGun
    
    ' TABLO GÖRÜNÜMÜ
    Dim tbl As ListObject
    On Error Resume Next
    wsH.ListObjects(1).Delete
    On Error GoTo 0
    
    Set tbl = wsH.ListObjects.Add(xlSrcRange, wsH.Range(wsH.Cells(1, 1), wsH.Cells(satir - 1, sonKolon)), , xlYes)
'    Set tbl = wsH.ListObjects.Add(xlSrcRange, wsH.Range(wsH.Cells(1, 1), wsH.Cells(satir, sonKolon)), , xlYes)
    tbl.Name = "SonucTablosu"
    tbl.ShowHeaders = True
   tbl.ShowTotals = False
    MsgBox "İşlem tamamlandı!", vbInformation

End Sub
 
yakamozexcel' Alıntı:
Kod: 
Sub TC_Tek_Tablo()

    Dim wsK As Worksheet, wsH As Worksheet
    Dim sonSatir As Long, sonKolon As Long
    Dim i As Long, j As Long
    Dim dict As Object
    Dim TC As String
    Dim veri As Variant
    Dim satir As Long
    Dim toplamGun As Double
   
    Set wsK = ThisWorkbook.Sheets("Sayfa1")
    Set wsH = ThisWorkbook.Sheets("Sayfa2")
   
    wsH.Cells.Clear
   
    Set dict = CreateObject("Scripting.Dictionary")
   
    sonSatir = wsK.Cells(wsK.Rows.Count, "G").End(xlUp).Row
    sonKolon = wsK.Cells(1, wsK.Columns.Count).End(xlToLeft).Column
   
    ' Başlıkları kopyala
    For j = 1 To sonKolon
        wsH.Cells(1, j).Value = wsK.Cells(1, j).Value
    Next j
   
    satir = 2
   
    For i = 2 To sonSatir
       
        TC = Trim(wsK.Cells(i, "G").Value)
        veri = wsK.Cells(i, "L").Value
       
        If IsNumeric(veri) Then
            gun = CDbl(veri)
        Else
            gun = 0
        End If
       
        If TC <> "" Then
           
            If dict.exists(TC) Then
                ' Gün Sayısını ekle
                wsH.Cells(dict(TC), "L").Value = wsH.Cells(dict(TC), "L").Value + gun
           
            Else
                ' Satırı komple kopyala
                For j = 1 To sonKolon
                    wsH.Cells(satir, j).Value = wsK.Cells(i, j).Value
                Next j
               
                ' Gün sayısını garanti numeric yaz
                wsH.Cells(satir, "L").Value = gun
               
                dict.Add TC, satir
                satir = satir + 1
            End If
           
        End If
       
    Next i
   
'    ' GENEL TOPLAM
'    toplamGun = 0
'
'    For i = 2 To satir - 1
'        If IsNumeric(wsH.Cells(i, "L").Value) Then
'            toplamGun = toplamGun + wsH.Cells(i, "L").Value
'        End If
'    Next i
'
'    wsH.Cells(satir, "K").Value = "GENEL TOPLAM"
'    wsH.Cells(satir, "L").Value = toplamGun
   
    ' TABLO GÖRÜNÜMÜ
    Dim tbl As ListObject
    On Error Resume Next
    wsH.ListObjects(1).Delete
    On Error GoTo 0
   
    Set tbl = wsH.ListObjects.Add(xlSrcRange, wsH.Range(wsH.Cells(1, 1), wsH.Cells(satir - 1, sonKolon)), , xlYes)
'    Set tbl = wsH.ListObjects.Add(xlSrcRange, wsH.Range(wsH.Cells(1, 1), wsH.Cells(satir, sonKolon)), , xlYes)
    tbl.Name = "SonucTablosu"
    tbl.ShowHeaders = True
   tbl.ShowTotals = False
    MsgBox "İşlem tamamlandı!", vbInformation

End Sub
Genişletmek için tıkla ...
Çok Teşekkür ederim. Asıl dosyamda denedim sorunsuz çalışıyor.
 
Muzaffer Ali' Alıntı:
Merhaba.
Alternatif olsun.

M2 hücresine aşağıdaki formülü kopyalayıp aşağı doğru çoğaltın.
Kod: 
=ETOPLA($G$2:$G$100;G2;$L$2:$L$100)
M sütununu kopyalayıp değerleri yapıştırın.(Formülleri kaldırmak için)

Yinelenenleri kaldır işlemini yapın.
M sütunundaki değerleri L'ye kopyalayın.
Genişletmek için tıkla ...

sayın Muzaffer Ali Çok teşekkür ederim. Asıl dosyamda ki satır ve sütün sayıları çok fazla olduğu için makro ile yapabilirmiyiz diye düşünmüştüm. yakamozexcel sağ olsun istediğimi yapmakta yardımcı oldu.​

 
Alternatif daha kısa ve basit kod.
Yeni bir sayfa eklemeden var olan sayfada düzenleme yapar.
Kod: 
Sub TC_Tek_Tablo_AyniSayfa()
    Dim Dict As Object
    Dim Bak As Long
    Dim SonSatir As Long
    Dim Sira As Long
    Dim TC As String
    Dim Gun As Double
   
    Set Dict = CreateObject("Scripting.Dictionary")
    SonSatir = Cells(Rows.Count, "G").End(xlUp).Row
    Sira = 2
    Application.ScreenUpdating = False
    For Bak = 2 To SonSatir
        TC = Trim(Cells(Bak, "G").Value)
        Gun = Val(Cells(Bak, "L").Value)
        If TC <> "" Then
            If Dict.exists(TC) Then
                Cells(Dict(TC), "L").Value = Cells(Dict(TC), "L").Value + Gun
                Rows(Bak).Delete
                Bak = Bak - 1
                SonSatir = SonSatir - 1
            Else
                Dict.Add TC, Sira
                Sira = Sira + 1
            End If
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Yinelenenler kaldırıldı ve Gün Sayısı toplandı!", vbInformation
End Sub
 
Son düzenleme:
Alternatif olarak özet tabloyu kullanabilirsiniz. Esnek yapısı sayesinde hızlı şekilde farklı raporlar üretebilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst