Karşılaştırma Listeleri

K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
Daha önce forumdan edindiğim, çok değerli ustaların yaptığı bir çalışma mevcut elimde.
Ancak dosya formül üzerine olduğu için satır sayısı uzadıkça kasmalar yaşanıyor.
Söz konusu formülleri makroya çevirebilir miyiz?
Satır sayısı A ve B Sütunu maksimum sayısı kadar olması yeterlidir.
Değerli vaktini ayırıp yardımcı olabilecek ustalara teşekkür ederim.
 

Ekli dosyalar

veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,655
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub test()
    
    Dim sat&(1 To 12), son&, al(), i&, _
    dic1 As Object, itms, kys, tekrarSay
    
    For i = 1 To 12
        sat(i) = 4
    Next i
    
    Set dic1 = CreateObject("Scripting.Dictionary")
    
    Range("G4:R" & Rows.Count).ClearContents
    
    With dic1
        son = Cells(Rows.Count, 1).End(3).Row
        al = Range("A4:A" & son).Value
        For i = 1 To UBound(al)
            .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
        itms = .items
        kys = .keys
        Cells(sat(5), "K").Value = .Count
        tekrarSay = 0
        For i = 0 To UBound(kys)
            Cells(sat(6) + i, "L").Value = kys(i)
            Cells(sat(4) + i, "J").Value = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                Cells(sat(10), "P").Resize(itms(i)).Value = kys(i)
                sat(10) = sat(10) + itms(i)
            End If
        Next i
        sat(4) = sat(4) + i
        Cells(sat(9), "O").Value = tekrarSay
    End With
 
    With CreateObject("Scripting.Dictionary")
        son = Cells(Rows.Count, 2).End(3).Row
        al = Range("B4:B" & son).Value
        For i = 1 To UBound(al)
            .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
        For i = 0 To UBound(kys)
            If Not .exists(kys(i)) Then
                Cells(sat(1), "G").Value = kys(i)
                sat(1) = sat(1) + 1
            End If
        Next i
        itms = .items
        kys = .keys
        Cells(sat(7), "M").Value = .Count
        tekrarSay = 0
        For i = 0 To UBound(kys)
            Cells(sat(8) + i, "N").Value = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                Cells(sat(12), "R").Resize(itms(i)).Value = kys(i)
                sat(12) = sat(12) + itms(i)
            End If
            If Not dic1.exists(kys(i)) Then
                Cells(sat(4), "J").Value = kys(i)
                sat(4) = sat(4) + 1
                Cells(sat(2), "H").Value = kys(i)
                sat(2) = sat(2) + 1
            Else
                Cells(sat(3), "I").Value = kys(i)
                sat(3) = sat(3) + 1
            End If
        Next i
        Cells(sat(11), "Q").Value = tekrarSay
    End With
End Sub
 
D

dost

Katılım
15 Mart 2005
Mesajlar
387
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

NOT: Sayın veyselemre'nin cevabını yeni gördüm. Ayrıca R sütununa kadar doldurulması gerekiyormuş :( O kısmı da yapayım bari :)

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim x, y, match As Boolean
Dim i As Long
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:J" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

For Each Item In MyArr1
     If dict.Exists(Item) = False Then dict.Add Item, 1
Next

MyArr1 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
   
eDic = dict.RemoveAll

For Each Item In MyArr2
     If dict.Exists(Item) = False Then dict.Add Item, 1
Next

MyArr2 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
   
For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item

For Each Item In MyArr2
     iCont = False
     For Each Item2 In MyArr1
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item
   
Application.ScreenUpdating = True

End Sub
 
Son düzenleme:
D

dost

Katılım
15 Mart 2005
Mesajlar
387
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

#3 nolu mesajımın revize edilmiş şeklidir.

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j, k As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not dict.Exists(MyArr1(j, 1)) Then
        dict.Add MyArr1(j, 1), 1
    Else
        dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
    End If
Next
      
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "P") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
  
eDic = dict.RemoveAll

iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not dict.Exists(MyArr2(j, 1)) Then
        dict.Add MyArr2(j, 1), 1
    Else
        dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
    End If
Next
      
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "R") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
  
For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item

For Each Item In MyArr2
     iCont = False
     For Each Item2 In MyArr1
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item
  
Application.ScreenUpdating = True

End Sub
 
Son düzenleme:
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,655
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub test()
   
    Dim sat&(1 To 12), al(), i&, ii&, itms, kys, tekrarSay&, sonA&, sonB&
   
    For i = 1 To 12
        sat(i) = 1
    Next i
   
    Range("G4:R" & Rows.Count).ClearContents
   
    With CreateObject("Scripting.Dictionary")
       
        sonA = Cells(Rows.Count, 1).End(3).Row
        sonB = Cells(Rows.Count, 2).End(3).Row
        ReDim veri(1 To (sonA + sonB), 1 To 12)
       
        al = Range("A4:A" & sonA).Value
       
        For i = 1 To UBound(al)
            If al(i, 1) <> "" Then .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
       
        itms = .items
        kys = .keys
       
        veri(sat(5), 5) = .Count
       
        tekrarSay = 0
       
        For i = 0 To UBound(kys)
            veri(sat(6) + i, 6) = kys(i)
            veri(sat(4) + i, 4) = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                For ii = 1 To itms(i)
                    veri(sat(10), 10) = kys(i)
                    sat(10) = sat(10) + 1
                Next ii
            End If
        Next i
       
        sat(4) = sat(4) + i
        veri(sat(9), 9) = tekrarSay
        .RemoveAll
       
        al = Range("B4:B" & sonB).Value
        For i = 1 To UBound(al)
            If al(i, 1) <> "" Then .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
      
        kys = .keys
        itms = .items
        tekrarSay = 0
       
        For i = 0 To UBound(kys)
            veri(sat(8) + i, 8) = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                For ii = 1 To itms(i)
                    veri(sat(12), 12) = kys(i)
                    sat(12) = sat(12) + 1
                Next ii
            End If
        Next i
       
        veri(sat(7), 7) = .Count
        veri(sat(11), 11) = tekrarSay

        For i = 1 To sat(4)
            If .exists(veri(i, 4)) Then
                veri(sat(3), 3) = veri(i, 4)
                sat(3) = sat(3) + 1
                .Remove veri(i, 4)
            Else
                veri(sat(1), 1) = veri(i, 4)
                sat(1) = sat(1) + 1
            End If
        Next i
       
        If .Count > 0 Then
            kys = .keys
            For i = 0 To UBound(kys)
                veri(sat(2), 2) = kys(i)
                veri(sat(4), 4) = kys(i)
                sat(2) = sat(2) + 1
                sat(4) = sat(4) + 1
            Next i
        End If
        Range("G4").Resize(WorksheetFunction.Max(sat), 12).Value = veri
       
    End With

End Sub
 
Son düzenleme:
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
dost' Alıntı:
Merhaba,

#3 nolu mesajımın revize edilmiş şeklidir.

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j, k As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not dict.Exists(MyArr1(j, 1)) Then
        dict.Add MyArr1(j, 1), 1
    Else
        dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
    End If
Next
     
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "P") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
 
eDic = dict.RemoveAll

iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not dict.Exists(MyArr2(j, 1)) Then
        dict.Add MyArr2(j, 1), 1
    Else
        dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
    End If
Next
     
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "R") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
 
For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item

For Each Item In MyArr2
     iCont = False
     For Each Item2 In MyArr1
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item
 
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...

Hocam ilginiz için çok teşekkür ederim.
Ancak G ve H sütunu şu sorgulamayı yapması gerekiyor,
Örneğin H Sütununda bir tane "ABDULLAH BALCI" ismi eksik nedeni şöyle;
LİSTE2 de 2 tane ABDULLAH BALCI var LİSTE1 de 1 tane .
Yine aynı şekilde; H sütununda 100 rakamı 1 tane eksik o da, diğer liste ile kıyaslandığında bir tane fazla olması gerekiyor.
Aynı mantık G sütunu içinde geçerli.
Bu şekilde düzeltmemiz mümkün olursa daha güzel olacak.
Tekrar teşekkür ederim.
 
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
veyselemre' Alıntı:
Kod: 
Sub test()
   
    Dim sat&(1 To 12), al(), i&, ii&, itms, kys, tekrarSay&, sonA&, sonB&
   
    For i = 1 To 12
        sat(i) = 1
    Next i
   
    Range("G4:R" & Rows.Count).ClearContents
   
    With CreateObject("Scripting.Dictionary")
       
        sonA = Cells(Rows.Count, 1).End(3).Row
        sonB = Cells(Rows.Count, 2).End(3).Row
        ReDim veri(1 To (sonA + sonB), 1 To 12)
       
        al = Range("A4:A" & sonA).Value
       
        For i = 1 To UBound(al)
            .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
       
        itms = .items
        kys = .keys
       
        veri(sat(5), 5) = .Count
       
        tekrarSay = 0
       
        For i = 0 To UBound(kys)
            veri(sat(6) + i, 6) = kys(i)
            veri(sat(4) + i, 4) = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                For ii = 1 To itms(i)
                    veri(sat(10), 10) = kys(i)
                    sat(10) = sat(10) + 1
                Next ii
            End If
        Next i
       
        sat(4) = sat(4) + i
        veri(sat(9), 9) = tekrarSay
        .RemoveAll
       
        al = Range("B4:B" & sonB).Value
        For i = 1 To UBound(al)
            .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
      
        kys = .keys
        itms = .items
        tekrarSay = 0
       
        For i = 0 To UBound(kys)
            veri(sat(8) + i, 8) = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                For ii = 1 To itms(i)
                    veri(sat(12), 12) = kys(i)
                    sat(12) = sat(12) + 1
                Next ii
            End If
        Next i
       
        veri(sat(7), 7) = .Count
        veri(sat(11), 11) = tekrarSay

        For i = 1 To sat(4)
            If .exists(veri(i, 4)) Then
                veri(sat(3), 3) = veri(i, 4)
                sat(3) = sat(3) + 1
                .Remove veri(i, 4)
            Else
                veri(sat(1), 1) = veri(i, 4)
                sat(1) = sat(1) + 1
            End If
        Next i
       
        If .Count > 0 Then
            kys = .keys
            For i = 0 To UBound(kys)
                veri(sat(2), 2) = kys(i)
                veri(sat(4), 4) = kys(i)
                sat(2) = sat(2) + 1
                sat(4) = sat(4) + 1
            Next i
        End If
        Range("G4").Resize(sat(4), 12).Value = veri
       
    End With

End Sub
Genişletmek için tıkla ...
Hocam ilginiz için çok teşekkür ederim.
Ancak G ve H sütunu şu sorgulamayı yapması gerekiyor,
Örneğin H Sütununda bir tane "ABDULLAH BALCI" ismi eksik nedeni şöyle;
LİSTE2 de 2 tane ABDULLAH BALCI var LİSTE1 de 1 tane .
Yine aynı şekilde; H sütununda 100 rakamı 1 tane eksik o da, diğer liste ile kıyaslandığında bir tane fazla olması gerekiyor.
Aynı mantık G sütunu içinde geçerli.
Bu şekilde düzeltmemiz mümkün olursa daha güzel olacak.
Tekrar teşekkür ederim.
 
D

dost

Katılım
15 Mart 2005
Mesajlar
387
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

Aşağıdaki kodları test edersiniz.

Kod: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, iCounter2, j, y As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value
 
Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not dict.Exists(MyArr1(j, 1)) Then
        dict.Add MyArr1(j, 1), 1
    Else
        dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
    End If
Next
       
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "P") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
   
eDic = dict.RemoveAll

iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not dict.Exists(MyArr2(j, 1)) Then
        dict.Add MyArr2(j, 1), 1
    Else
        dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
    End If
Next
       
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "R") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
    
For Each Item In MyArr1
     iCont = False:   iCounter = 0:   iCounter2 = 0
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True: Exit For
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
         iCounter = WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), Item)
         iCounter2 = WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), Item2)
         If iCounter > iCounter2 Then
            For y = 1 To (iCounter - iCounter2)
                Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
            Next y
         End If
     End If
Next Item

For Each Item2 In MyArr2
     iCont = False:   iCounter = 0:   iCounter2 = 0
     For Each Item In MyArr1
         If Item2 = Item Then iCont = True:  Exit For
     Next Item
     If Not iCont Then
        Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item2
     Else
        iCounter2 = WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), Item2)
        iCounter = WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), Item)
        If iCounter2 > iCounter Then
            For y = 1 To (iCounter2 - iCounter)
                Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item2
            Next y
        End If
     End If
Next Item2
   
Application.ScreenUpdating = True

End Sub
 
Son düzenleme:
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
dost' Alıntı:
Merhaba,

Aşağıdaki kodları test edersiniz.

Kod: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, iCounter2, j, y As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not dict.Exists(MyArr1(j, 1)) Then
        dict.Add MyArr1(j, 1), 1
    Else
        dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
    End If
Next
      
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "P") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
  
eDic = dict.RemoveAll

iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not dict.Exists(MyArr2(j, 1)) Then
        dict.Add MyArr2(j, 1), 1
    Else
        dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
    End If
Next
      
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "R") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
   
For Each Item In MyArr1
     iCont = False:   iCounter = 0:   iCounter2 = 0
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True: Exit For
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
         iCounter = WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), Item)
         iCounter2 = WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), Item2)
         If iCounter > iCounter2 Then
            For y = 1 To (iCounter - iCounter2)
                Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
            Next y
         End If
     End If
Next Item

For Each Item2 In MyArr2
     iCont = False:   iCounter = 0:   iCounter2 = 0
     For Each Item In MyArr1
         If Item2 = Item Then iCont = True:  Exit For
     Next Item
     If Not iCont Then
        Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item2
     Else
        iCounter2 = WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), Item2)
        iCounter = WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), Item)
        If iCounter2 > iCounter Then
            For y = 1 To (iCounter2 - iCounter)
                Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item2
            Next y
        End If
     End If
Next Item2
  
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
Emekleriniz için teşekkür ederim,
Ancak aralarda boş satır olduğunda sonuçlar doğru çıkmıyor,
 
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
veyselemre' Alıntı:
Kod: 
Sub test()
   
    Dim sat&(1 To 12), al(), i&, ii&, itms, kys, tekrarSay&, sonA&, sonB&
   
    For i = 1 To 12
        sat(i) = 1
    Next i
   
    Range("G4:R" & Rows.Count).ClearContents
   
    With CreateObject("Scripting.Dictionary")
       
        sonA = Cells(Rows.Count, 1).End(3).Row
        sonB = Cells(Rows.Count, 2).End(3).Row
        ReDim veri(1 To (sonA + sonB), 1 To 12)
       
        al = Range("A4:A" & sonA).Value
       
        For i = 1 To UBound(al)
            .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
       
        itms = .items
        kys = .keys
       
        veri(sat(5), 5) = .Count
       
        tekrarSay = 0
       
        For i = 0 To UBound(kys)
            veri(sat(6) + i, 6) = kys(i)
            veri(sat(4) + i, 4) = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                For ii = 1 To itms(i)
                    veri(sat(10), 10) = kys(i)
                    sat(10) = sat(10) + 1
                Next ii
            End If
        Next i
       
        sat(4) = sat(4) + i
        veri(sat(9), 9) = tekrarSay
        .RemoveAll
       
        al = Range("B4:B" & sonB).Value
        For i = 1 To UBound(al)
            .Item(al(i, 1)) = .Item(al(i, 1)) + 1
        Next i
      
        kys = .keys
        itms = .items
        tekrarSay = 0
       
        For i = 0 To UBound(kys)
            veri(sat(8) + i, 8) = kys(i)
            If itms(i) > 1 Then
                tekrarSay = tekrarSay + itms(i)
                For ii = 1 To itms(i)
                    veri(sat(12), 12) = kys(i)
                    sat(12) = sat(12) + 1
                Next ii
            End If
        Next i
       
        veri(sat(7), 7) = .Count
        veri(sat(11), 11) = tekrarSay

        For i = 1 To sat(4)
            If .exists(veri(i, 4)) Then
                veri(sat(3), 3) = veri(i, 4)
                sat(3) = sat(3) + 1
                .Remove veri(i, 4)
            Else
                veri(sat(1), 1) = veri(i, 4)
                sat(1) = sat(1) + 1
            End If
        Next i
       
        If .Count > 0 Then
            kys = .keys
            For i = 0 To UBound(kys)
                veri(sat(2), 2) = kys(i)
                veri(sat(4), 4) = kys(i)
                sat(2) = sat(2) + 1
                sat(4) = sat(4) + 1
            Next i
        End If
        Range("G4").Resize(sat(4), 12).Value = veri
       
    End With

End Sub
Genişletmek için tıkla ...
Sayın Veysel Emre,
Kodu denediğimde,
G sütunu için; LİSTE1 de "ankara0600" değeri 2 tane LİSTE2 de 1 tane dolayısıyla, G Sütununda 1 tane "ankara0600" olması gerekiyor.
H Sütunu için; LİSTE2 de "ABDULLAH BALCI" değeri 12 tane var, H sütununda 12 tane "ABDULLAH BALCI" olması gerekiyor,
Bir de makro yeniden çalıştığında, eski biçimlendirme kalıyor, sonucu etkiliyor,
O Sütunu için; Tekrar sayısı 18 gösteriyor Ancak P sütununda 2 tane listeliyor
Aynı durum Q ve R sütunu için de geçerlidir.
Eğer bu durum boş hücrelerden kaynaklanıyor ise, LİSTE1 ve LİSTE2 de boşluklar kod ile silinse çözüm olur mu?

Kıymetli vaktinizi yardım etmek için ayırdığınız için çok teşekkür ederim.
Selamlar,
 

Ekli dosyalar

D

dost

Katılım
15 Mart 2005
Mesajlar
387
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
konas06' Alıntı:
Emekleriniz için teşekkür ederim,
Ancak aralarda boş satır olduğunda sonuçlar doğru çıkmıyor,
Genişletmek için tıkla ...
Merhaba,

Denersiniz...

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

 Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

 MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
 MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value
 
 Set dict = CreateObject("Scripting.Dictionary")
 
 iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1
 
 For j = LBound(MyArr1) To UBound(MyArr1)
    If Not IsEmpty(MyArr1(j, 1)) Then
        If Not dict.Exists(MyArr1(j, 1)) Then
            dict.Add MyArr1(j, 1), 1
        Else
            dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
        End If
    End If
 Next
        
 For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "P") = key
            iRow = iRow + 1
        Next k
    End If
 Next
 
 MyArr1 = WorksheetFunction.Transpose(dict.Keys())

 Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
 Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
 Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
 Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
    
 eDic = dict.RemoveAll
 
 iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

 For j = LBound(MyArr2) To UBound(MyArr2)
    If Not IsEmpty(MyArr2(j, 1)) Then
        If Not dict.Exists(MyArr2(j, 1)) Then
            dict.Add MyArr2(j, 1), 1
        Else
            dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
        End If
    End If
 Next
        
 For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "R") = key
            iRow = iRow + 1
        Next k
    End If
 Next
 
 MyArr2 = WorksheetFunction.Transpose(dict.Keys())
 
 Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
 Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
 Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
 Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
    
 For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
     End If
 Next Item
 
 For Each Item In MyArr2
     iCont = False
     For Each Item2 In MyArr1
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item
     End If
 Next Item
    
Application.ScreenUpdating = True

End Sub
 
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
dost' Alıntı:
Merhaba,

Denersiniz...

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not IsEmpty(MyArr1(j, 1)) Then
        If Not dict.Exists(MyArr1(j, 1)) Then
            dict.Add MyArr1(j, 1), 1
        Else
            dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
        End If
    End If
Next
       
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "P") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
   
eDic = dict.RemoveAll

iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not IsEmpty(MyArr2(j, 1)) Then
        If Not dict.Exists(MyArr2(j, 1)) Then
            dict.Add MyArr2(j, 1), 1
        Else
            dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
        End If
    End If
Next
       
For Each key In dict.Keys
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        For k = 1 To dict(key)
            Cells(iRow, "R") = key
            iRow = iRow + 1
        Next k
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.Keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.Keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
   
For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("G" & Range("G" & Rows.Count).End(xlUp).row + 1) = Item
     Else
         Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item

For Each Item In MyArr2
     iCont = False
     For Each Item2 In MyArr1
         If Item = Item2 Then iCont = True
     Next Item2
     If Not iCont Then
         Range("H" & Range("H" & Rows.Count).End(xlUp).row + 1) = Item
     End If
Next Item
   
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
Üstadım teşekkür ederim,
Ancak LİSTELER arası karşılaştırma yapıp, farklı olanı göstermesi gerekiyor.
Örneğin H sütununda "ABDULLAH BALCI" değerinin 2 tane olması lazım.
 
D

dost

Katılım
15 Mart 2005
Mesajlar
387
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
konas06' Alıntı:
Üstadım teşekkür ederim,
Ancak LİSTELER arası karşılaştırma yapıp, farklı olanı göstermesi gerekiyor.
Örneğin H sütununda "ABDULLAH BALCI" değerinin 2 tane olması lazım.
Genişletmek için tıkla ...
Merhaba,

"G" ve "H" sütunları doğru çalışıyor şimdi. Umarım :)

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j, iDiff As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

 Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

 MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
 MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value
 
 Set dict = CreateObject("Scripting.Dictionary")
 
 iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1
 
 For j = LBound(MyArr1) To UBound(MyArr1)
    If Not IsEmpty(MyArr1(j, 1)) Then
        If Not dict.Exists(MyArr1(j, 1)) Then
            dict.Add MyArr1(j, 1), 1
        Else
            dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
        End If
    End If
 Next
        
 For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("G" & Rows.Count).End(xlUp).row + 1, "G").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("P" & Rows.Count).End(xlUp).row + 1, "P").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
 Next
 
 MyArr1 = WorksheetFunction.Transpose(dict.keys())

 Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
 Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
    
 eDic = dict.RemoveAll
 
 iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

 For j = LBound(MyArr2) To UBound(MyArr2)
    If Not IsEmpty(MyArr2(j, 1)) Then
        If Not dict.Exists(MyArr2(j, 1)) Then
            dict.Add MyArr2(j, 1), 1
        Else
            dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
        End If
    End If
 Next
        
 For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("H" & Rows.Count).End(xlUp).row + 1, "H").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("R" & Rows.Count).End(xlUp).row + 1, "R").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
 Next
 
 MyArr2 = WorksheetFunction.Transpose(dict.keys())
 
 Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
 Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
    
 For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True:  Exit For
     Next Item2
     If iCont Then Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
 Next Item
    
Application.ScreenUpdating = True

End Sub
 
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
dost' Alıntı:
Merhaba,

"G" ve "H" sütunları doğru çalışıyor şimdi. Umarım :)

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j, iDiff As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0:  iRow = Range("P" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not IsEmpty(MyArr1(j, 1)) Then
        If Not dict.Exists(MyArr1(j, 1)) Then
            dict.Add MyArr1(j, 1), 1
        Else
            dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
        End If
    End If
Next
       
For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("G" & Rows.Count).End(xlUp).row + 1, "G").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("P" & Rows.Count).End(xlUp).row + 1, "P").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
   
eDic = dict.RemoveAll

iCounter = 0:  iRow = Range("R" & Rows.Count).End(xlUp).row + 1

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not IsEmpty(MyArr2(j, 1)) Then
        If Not dict.Exists(MyArr2(j, 1)) Then
            dict.Add MyArr2(j, 1), 1
        Else
            dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
        End If
    End If
Next
       
For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("H" & Rows.Count).End(xlUp).row + 1, "H").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("R" & Rows.Count).End(xlUp).row + 1, "R").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
   
For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True:  Exit For
     Next Item2
     If iCont Then Range("I" & Range("I" & Rows.Count).End(xlUp).row + 1) = Item
Next Item
   
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
Merhaba,
"G" ve "H" sütunları doğru çalışıyor
"J" Sütununda LİSTE1 ve LİSTE2 Birleşiminin tekrarsız şeklinde olmasını sağlayabilir miyiz.
Çok teşekkür ederim.
 
D

dost

Katılım
15 Mart 2005
Mesajlar
387
Excel Vers. ve Dili
Microsoft 2016 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j, iDiff As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

 Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

 MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
 MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value
 
 Set dict = CreateObject("Scripting.Dictionary")
 
 iCounter = 0
 
 For j = LBound(MyArr1) To UBound(MyArr1)
    If Not IsEmpty(MyArr1(j, 1)) Then
        If Not dict.Exists(MyArr1(j, 1)) Then
            dict.Add MyArr1(j, 1), 1
        Else
            dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
        End If
    End If
 Next
        
 For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("G" & Rows.Count).End(xlUp).row + 1, "G").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("P" & Rows.Count).End(xlUp).row + 1, "P").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
 Next
 
 MyArr1 = WorksheetFunction.Transpose(dict.keys())

 Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
 Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
    
 dict.RemoveAll
 iCounter = 0

 For j = LBound(MyArr2) To UBound(MyArr2)
    If Not IsEmpty(MyArr2(j, 1)) Then
        If Not dict.Exists(MyArr2(j, 1)) Then
            dict.Add MyArr2(j, 1), 1
        Else
            dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
        End If
    End If
 Next
        
 For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("H" & Rows.Count).End(xlUp).row + 1, "H").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("R" & Rows.Count).End(xlUp).row + 1, "R").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
 Next
 
 MyArr2 = WorksheetFunction.Transpose(dict.keys())
 
 Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
 Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.keys())
 Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
    
 iRow = Range("I" & Rows.Count).End(xlUp).row + 1
 For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True:  Exit For
     Next Item2
     If iCont Then Range("I" & iRow) = Item:    iRow = iRow + 1
 Next Item
 
 iRow = Range("J" & Rows.Count).End(xlUp).row + 1
 For Each Item2 In MyArr2
     iCont = False
     For Each Item In MyArr1
         If Item2 = Item Then iCont = True:  Exit For
     Next Item
     If Not iCont Then Range("J" & iRow) = Item2:    iRow = iRow + 1
 Next Item2
    
Application.ScreenUpdating = True

End Sub
 
K

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2025
dost' Alıntı:
Merhaba,

C++: 
Sub listele()

Dim MyArr1, MyArr2 As Variant
Dim key As Variant
Dim i, iRow As Long
Dim iCounter, j, iDiff As Integer
Dim iCont As Boolean
Dim Item, Item2, dict, eDic

Application.ScreenUpdating = False

Range("G4:R" & ActiveSheet.UsedRange.Rows.Count).ClearContents

MyArr1 = Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row).Value
MyArr2 = Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row).Value

Set dict = CreateObject("Scripting.Dictionary")

iCounter = 0

For j = LBound(MyArr1) To UBound(MyArr1)
    If Not IsEmpty(MyArr1(j, 1)) Then
        If Not dict.Exists(MyArr1(j, 1)) Then
            dict.Add MyArr1(j, 1), 1
        Else
            dict.Item(MyArr1(j, 1)) = dict.Item(MyArr1(j, 1)) + 1
        End If
    End If
Next
       
For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("G" & Rows.Count).End(xlUp).row + 1, "G").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("P" & Rows.Count).End(xlUp).row + 1, "P").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
Next

MyArr1 = WorksheetFunction.Transpose(dict.keys())

Cells(Range("J" & Rows.Count).End(xlUp).row + 1, "J").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("K" & Rows.Count).End(xlUp).row + 1, "K") = UBound(MyArr1)
Cells(Range("L" & Rows.Count).End(xlUp).row + 1, "L").Resize(UBound(MyArr1)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("O" & Rows.Count).End(xlUp).row + 1, "O") = iCounter
   
dict.RemoveAll
iCounter = 0

For j = LBound(MyArr2) To UBound(MyArr2)
    If Not IsEmpty(MyArr2(j, 1)) Then
        If Not dict.Exists(MyArr2(j, 1)) Then
            dict.Add MyArr2(j, 1), 1
        Else
            dict.Item(MyArr2(j, 1)) = dict.Item(MyArr2(j, 1)) + 1
        End If
    End If
Next
       
For Each key In dict.keys
    iDiff = 0
    iDiff = dict(key) - WorksheetFunction.CountIf(Range("A4:A" & Range("A" & Rows.Count).End(xlUp).row), key)
    If iDiff > 0 Then Cells(Range("H" & Rows.Count).End(xlUp).row + 1, "H").Resize(iDiff) = WorksheetFunction.Transpose(key)
    If dict(key) > 1 Then
        iCounter = iCounter + dict(key)
        Cells(Range("R" & Rows.Count).End(xlUp).row + 1, "R").Resize(dict(key)) = WorksheetFunction.Transpose(key)
    End If
Next

MyArr2 = WorksheetFunction.Transpose(dict.keys())

Cells(Range("M" & Rows.Count).End(xlUp).row + 1, "M") = UBound(MyArr2)
Cells(Range("N" & Rows.Count).End(xlUp).row + 1, "N").Resize(UBound(MyArr2)) = WorksheetFunction.Transpose(dict.keys())
Cells(Range("Q" & Rows.Count).End(xlUp).row + 1, "Q") = iCounter
   
iRow = Range("I" & Rows.Count).End(xlUp).row + 1
For Each Item In MyArr1
     iCont = False
     For Each Item2 In MyArr2
         If Item = Item2 Then iCont = True:  Exit For
     Next Item2
     If iCont Then Range("I" & iRow) = Item:    iRow = iRow + 1
Next Item

iRow = Range("J" & Rows.Count).End(xlUp).row + 1
For Each Item2 In MyArr2
     iCont = False
     For Each Item In MyArr1
         If Item2 = Item Then iCont = True:  Exit For
     Next Item
     If Not iCont Then Range("J" & iRow) = Item2:    iRow = iRow + 1
Next Item2
   
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
Merhaba,
İlginiz için çok teşekkür ederim,
Hoşgörünüze sığınarak; sanırım son soru,
10.04.1900 formatında değil de 101 şeklinde çıkmasını nasıl sağlarız
Diğer sütunlar için de benzer işlem gerekir mi
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Üst