Soru Yinelenenleri Kaldır Karşılıklarını Birleştir

[leonadies]

Değerli Üstadlar;

C: C var olan verilerim. İsteğim şöyle;

1) C:C sütunundaki veriler K2:K da yinelenenler kalkmış olarak listelenecek
2) L:L sütununa karşısındaki değerler arasına virgül koyularak yazdırılacak.

Kısacası ulaşmak istediğim görüntü K:L de verdim. Bunu makro ile yapmak istiyorum. Bu arada Buton Sayfa 1 de olacak makrolar sayfa 2 de çalışacak.

Dosyalarım ekli. Yapabilir miyiz?

 

[Necdet]

Merhaba,

Deneyiniz.

Sub Aktar()

    Dim d, _
        i As Long
   
    Set d = CreateObject("Scripting.Dictionary")
   
    For i = 2 To Cells(Rows.Count, "C").End(3).Row
        Deg = Cells(i, "C")
        If Not d.exists(Deg) Then
            d.Add Deg, Cells(i, "D")
        Else
            d.Item(Deg) = d.Item(Deg) & "," & Cells(i, "D")
        End If
       
    Next i
   
    Range("K2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
   
End Sub

 

[leonadies]

@Necdet Hocam çok teşekkür ederim. Makro aynı sayfada olunca çalışıyor. Benim amacım bunu 2.sayfada görmeden yapmak.

Yani 1.Sayfadaki butona tıklayınca bu işlemlerin 2 .sayfada olmasını istiyorum. Not 1 .sayfada hiç bir bilgi yok sadece buton var. Tüm bilgiler 2 .Sayfada

 

[Necdet]

Merhaba,
O zaman aşağıdaki gibi deneyin.

Sub Aktar()

    Dim d, _
        i   As Long, _
        s2  As Worksheet
  
    Set s2 = Sheets("Sekme 2")
    
    Set d = CreateObject("Scripting.Dictionary")
  
    For i = 2 To s2.Cells(Rows.Count, "C").End(3).Row
        Deg = s2.Cells(i, "C")
        If Not d.exists(Deg) Then
            d.Add Deg, s2.Cells(i, "D")
        Else
            d.Item(Deg) = d.Item(Deg) & "," & s2.Cells(i, "D")
        End If
      
    Next i
  
    s2.Range("K2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
  
End Sub

 

[leonadies]

İşlem tamam teşekkür ederim

 

[Necdet]

İşlem tamam teşekkür ederim

İki kodun arasında çok büyük bir fark yok. Sadece hangi sayfadan hangi bilgiyi okuyup aktaracaksınız, onu belirtiyorsunuz.

 

[Korhan Ayhan]

Üyelerimize sayfa tanımlamasını bile öğretemedik vesselam...

 

[leonadies]

@Necdet hocam bu kodda bazı aralıklarla Next i satırından sonraki kısım hataya düşüyor ve makro takılıyor. Çok denemeler yaptım asıl sebebi anlayamadım. Farklı bir alternatif oluşturabilirmiyiz? Aklımda satırlarda boşluk olması durumunda hataya düşüyor olma ihrtimali geldi ancak o da değil.
Farklı bir çözümleme olursa sevinirim.

 

[leonadies]

Üyelerimize sayfa tanımlamasını bile öğretemedik vesselam...

@Korhan Ayhan hocam aslında çok şey öğrendik sizlerden sağolun varolun. Özelikle konuda "Scripting.Dictionary" geçince benim olayı kavramam çok zorlaşıyor. Aslında Necdet hocamın ilk makrosunu düzeltip aynen bana önerdiği gibi yazmıştım. Ancak makro hata veriyordu. O yüzden emin olmak için yazdım. Meğer hata başka nedenmiş. onu da şimdi anlamış oldum.

 

[leonadies]

aynı olayı farklı makro ile çözümleyebilecek biri varmı?

 

[leonadies]

hatanın sebebini buldum. C : D sütununda boşluk olan satır olursa hata veriyor ve bu satırda takılıyor. Çözmek için ne yapmamız lazım?
s2.Range("K2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))

 

[Korhan Ayhan]

"For" döngüsünden sonra ilk satıra hücrenin boş olma durumunu kontrol eden bir if sorgu satırı ekleyip boş hücreleri atlatabilirsiniz. Ayrıca başlattığınız if sorgusunu "Next" ifadesinden önce End If ekleyerek kapatmanız gerekir.

Ek olarak eğer veri sayısı fazla ise Application.Transpose komutu hata verebilir.

Alternatif olarak aşağıdaki kodu deneyebilirsiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, Veri As Variant, Son As Long
    Dim X As Long, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Sekme 2")
   
    Son = S1.Cells(S1.Rows.Count, "C").End(3).Row
    If Son < 3 Then Son = 3
    Veri = S1.Range("C2:D" & Son).Value
               
    S1.Range("K2:L" & S1.Rows.Count).ClearContents

    ReDim Liste(1 To Son, 1 To 2)

    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Veri(X, 1) <> "" Then
                If Not .Exists(Veri(X, 1)) Then
                    Say = Say + 1
                    .Add Veri(X, 1), Say
                    Liste(Say, 1) = Veri(X, 1)
                    Liste(Say, 2) = Veri(X, 2)
                Else
                    Liste(.Item(Veri(X, 1)), 2) = Liste(.Item(Veri(X, 1)), 2) & "," & Veri(X, 2)
                End If
            End If
        Next
       
        S1.Range("K2").Resize(.Count, 2) = Liste
    End With
   
    Set S1 = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Orion1]

hatanın sebebini buldum. C : D sütununda boşluk olan satır olursa hata veriyor ve bu satırda takılıyor. Çözmek için ne yapmamız lazım?
s2.Range("K2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))

30 bini geçen satırlarda transpose hataya düşüyor.
Onada bakmak lazım.

 

[leonadies]

"For" döngüsünden sonra ilk satıra hücrenin boş olma durumunu kontrol eden bir if sorgu satırı ekleyip boş hücreleri atlatabilirsiniz. Ayrıca başlattığınız if sorgusunu "Next" ifadesinden önce End If ekleyerek kapatmanız gerekir.

Ek olarak eğer veri sayısı fazla ise Application.Transpose komutu hata verebilir.

Alternatif olarak aşağıdaki kodu deneyebilirsiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, Veri As Variant, Son As Long
    Dim X As Long, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Set S1 = Sheets("Sekme 2")
  
    Son = S1.Cells(S1.Rows.Count, "C").End(3).Row
    If Son < 3 Then Son = 3
    Veri = S1.Range("C2:D" & Son).Value
              
    S1.Range("K2:L" & S1.Rows.Count).ClearContents

    ReDim Liste(1 To Son, 1 To 2)

    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Veri(X, 1) <> "" Then
                If Not .Exists(Veri(X, 1)) Then
                    Say = Say + 1
                    .Add Veri(X, 1), Say
                    Liste(Say, 1) = Veri(X, 1)
                    Liste(Say, 2) = Veri(X, 2)
                Else
                    Liste(.Item(Veri(X, 1)), 2) = Liste(.Item(Veri(X, 1)), 2) & "," & Veri(X, 2)
                End If
            End If
        Next
      
        S1.Range("K2").Resize(.Count, 2) = Liste
    End With
  
    Set S1 = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Bu kod sorunsuz. Teşekkür ederim Sayın @Korhan Ayhan