Koşula göre bir sonraki satırları kontrol ederek yinelenenleri kaldırma

İremeylul · 7 Aralık 2021

Merhaba,

Bir üretim takip dosyası üstünde sadeleştirme yapmaya çalışıyorum. Ekteki dosyada üretim planı sayfasındaki değerleri, liste sayfası1. satırda yazdığı konulara göre yazdırmak istiyorum. Firmanın 1 ürününün farklı boylarda ve renkte ürünleri olabilmektedir. ilk koşulum her zaman aynı firmanın farklı ürünlerinin (aynu ürün farklı boy ve yüzey olabilir) ayırt edilmesi olacaktır. Farklı firmalarla çakışan aynı ürünler olabiliyor. Sütunda komple kontrol yapmaması gerekiyor.

firma adına göre P. no , kalıp, mm ve renge göre 5 koşullu yinelenenleri kalkmalıdır. Firmanın adı her durumda en üstteki ilk p.no sunun yanında kalmalıdır.

Örnekteki şekilde Antony firmasının 11111 farklı boyda 2 siparişi vardır. bu siparişlerin yüzeyleri birbirinden farklıdır. Tablo 1 'den tablo 2 haline çevirmem gerekiyor.
Excel dosyasında durum daha belirgindir.

Konu hakkında yol gösterebilir misiniz?

ÖmerFaruk · 7 Aralık 2021

1. Üretim planı sayfanızın tamamı mı listelenecek ?
2. Sıralama neye göre yapılacak ? Üretim sayfanızda sıralama sadece firma ismine göre. Parti noları sıralanacak mıdır?
3. Aynı P.No ya sahip olan ürünleri birleştiriyoruz. Birleşen satırlarda Kalıp - mm - Renk başlıklarında veri varsa bunları virgülle birleştiriyoruz.
Birinde Kalıp var diğerinde yoksa sadece olanın kalıbı yazılıyor.
Her ikisinde de Kalıp varsa virgülle birleştiriyoruz.
İkisinde de kalıp yoksa boş geçiyoruz. Doğru mudur?

İremeylul · 7 Aralık 2021

1.Evet üretim planı sayfasının tamamı listelenecektir.
2.Sıralamada firma ismi sonra parti noları sıralanacaktır.
Tüm kodu yazdıktan sonra aslında ilk önceliğim üretim planı sayfasında a sütununda yazan öncelik değerim 1 olanlar için liste1 sayfası ,2 olanlar için liste 2 sayfası, 3 olanlar için liste 3 olarak sayfalarım ilerleyecektir.
3.Kalıp bilgileri başka bir excel dosyasından düşey ara ile getiriliyor. Dolayısıyla aynı P. nolu profillerin kalıbı varsa tüm sipariş satırlarında yazacak, yoksa yazmayacaktır.
kalıp olmayanlar boş geçilecektir.

ÖmerFaruk · 8 Aralık 2021

Kullanılan Kodlar aşağıda.
Dosyanızı da ekledim.

C++:

Sub YeniListe()
Dim Son%, i%, Say1%, Say2%, Say3%, Veri As Variant, List1, List2, List3
Dim Dict1 As Object, Dict2 As Object, Dict3 As Object

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Son = Worksheets("ÜRETİM PLANI").Range("A" & Rows.Count).End(3).Row
    If Son < 3 Then Son = 3
    Veri = Worksheets("ÜRETİM PLANI").Range("A3:O" & Son).Value
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "myTempSheet" Then Worksheets(i).Delete: Exit For
    Next i
    Worksheets.Add.Name = "myTempSheet"
    Worksheets("myTempSheet").Range("A1").Resize(UBound(Veri), UBound(Veri, 2)) = Veri

    With Worksheets("myTempSheet")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("A1:A" & UBound(Veri)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=Range("C1:C" & UBound(Veri)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=Range("D1:D" & UBound(Veri)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange Range("A1:D" & UBound(Veri))
        .Sort.Header = xlNo
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
    
    Set Dict1 = CreateObject("Scripting.Dictionary")
    Set Dict2 = CreateObject("Scripting.Dictionary")
    Set Dict3 = CreateObject("Scripting.Dictionary")
    
    ReDim List1(1 To UBound(Veri), 1 To 5)
    ReDim List2(1 To UBound(Veri), 1 To 5)
    ReDim List3(1 To UBound(Veri), 1 To 5)
    
    Veri = Worksheets("myTempSheet").Range("A1").Resize(UBound(Veri), UBound(Veri, 2)).Value
    Worksheets("myTempSheet").Delete
    For i = 1 To UBound(Veri)
        Select Case Veri(i, 1)
            Case 1
                If Not Dict1.Exists(Veri(i, 3) & " - " & Veri(i, 4)) Then
                    Say1 = Say1 + 1
                    Dict1.Add Veri(i, 3) & " - " & Veri(i, 4), Say1
                    If Say1 = 1 Then
                        List1(Say1, 1) = Veri(i, 3)
                    Else
                        If Veri(i, 3) <> Split(Dict1.Keys()(Say1 - 2), " - ")(0) Then List1(Say1, 1) = Veri(i, 3)
                    End If
                    List1(Say1, 2) = Veri(i, 4)
                    List1(Say1, 3) = Veri(i, 5)
                    List1(Say1, 4) = Veri(i, 10)
                    List1(Say1, 5) = Veri(i, 15)
                Else
                    If Veri(i, 10) <> "" And Veri(i, 10) <> List1(Dict1(Veri(i, 3) & " - " & Veri(i, 4)), 4) Then
                        List1(Dict1(Veri(i, 3) & " - " & Veri(i, 4)), 4) = List1(Dict1(Veri(i, 3) & " - " & Veri(i, 4)), 4) & ", " & Veri(i, 10)
                    End If
                    If Veri(i, 15) <> "" And Veri(i, 15) <> List1(Dict1(Veri(i, 3) & " - " & Veri(i, 4)), 5) Then
                        List1(Dict1(Veri(i, 3) & " - " & Veri(i, 4)), 5) = List1(Dict1(Veri(i, 3) & " - " & Veri(i, 4)), 4) & ", " & Veri(i, 15)
                    End If
                End If

            Case 2
                If Not Dict2.Exists(Veri(i, 3) & " - " & Veri(i, 4)) Then
                    Say2 = Say2 + 1
                    Dict2.Add Veri(i, 3) & " - " & Veri(i, 4), Say2
                    If Say2 = 1 Then
                        List2(Say2, 1) = Veri(i, 3)
                    Else
                        If Veri(i, 3) <> Split(Dict2.Keys()(Say2 - 2), " - ")(0) Then List2(Say2, 1) = Veri(i, 3)
                    End If
                    List2(Say2, 2) = Veri(i, 4)
                    List2(Say2, 3) = Veri(i, 5)
                    List2(Say2, 4) = Veri(i, 10)
                    List2(Say2, 5) = Veri(i, 15)
                Else
                    If Veri(i, 10) <> "" And Veri(i, 10) <> List2(Dict2(Veri(i, 3) & " - " & Veri(i, 4)), 4) Then
                        List2(Dict2(Veri(i, 3) & " - " & Veri(i, 4)), 4) = List2(Dict2(Veri(i, 3) & " - " & Veri(i, 4)), 4) & ", " & Veri(i, 10)
                    End If
                    If Veri(i, 15) <> "" And Veri(i, 15) <> List2(Dict2(Veri(i, 3) & " - " & Veri(i, 4)), 5) Then
                        List2(Dict2(Veri(i, 3) & " - " & Veri(i, 4)), 5) = List2(Dict2(Veri(i, 3) & " - " & Veri(i, 4)), 4) & ", " & Veri(i, 15)
                    End If
                End If

            Case 3
                If Not Dict3.Exists(Veri(i, 3) & " - " & Veri(i, 4)) Then
                    Say3 = Say3 + 1
                    Dict3.Add Veri(i, 3) & " - " & Veri(i, 4), Say3
                    If Say3 = 1 Then
                        List3(Say3, 1) = Veri(i, 3)
                    Else
                        If Veri(i, 3) <> Split(Dict3.Keys()(Say3 - 2), " - ")(0) Then List3(Say3, 1) = Veri(i, 3)
                    End If
                    List3(Say3, 2) = Veri(i, 4)
                    List3(Say3, 3) = Veri(i, 5)
                    List3(Say3, 4) = Veri(i, 10)
                    List3(Say3, 5) = Veri(i, 15)
                Else
                    If Veri(i, 10) <> "" And Veri(i, 10) <> List3(Dict3(Veri(i, 3) & " - " & Veri(i, 4)), 4) Then
                        List3(Dict3(Veri(i, 3) & " - " & Veri(i, 4)), 4) = List3(Dict3(Veri(i, 3) & " - " & Veri(i, 4)), 4) & ", " & Veri(i, 10)
                    End If
                    If Veri(i, 15) <> "" And Veri(i, 15) <> List3(Dict3(Veri(i, 3) & " - " & Veri(i, 4)), 5) Then
                        List3(Dict3(Veri(i, 3) & " - " & Veri(i, 4)), 5) = List3(Dict3(Veri(i, 3) & " - " & Veri(i, 4)), 4) & ", " & Veri(i, 15)
                    End If
                End If
        End Select
    Next i
    
    Worksheets("Liste1").Cells.ClearContents
    Worksheets("Liste2").Cells.ClearContents
    Worksheets("Liste3").Cells.ClearContents
    If Say1 > 0 Then
        Worksheets("Liste1").Range("A1:E1") = Array("FİRMA", "P.NO", "KALIP", "MM", "RENK")
        Worksheets("Liste1").Range("A2").Resize(Say1, 5) = List1
        Worksheets("Liste1").Columns("A:E").EntireColumn.AutoFit
    End If
        
    If Say2 > 0 Then
        Worksheets("Liste2").Range("A1:E1") = Array("FİRMA", "P.NO", "KALIP", "MM", "RENK")
        Worksheets("Liste2").Range("A2").Resize(Say2, 5) = List2
        Worksheets("Liste2").Columns("A:E").EntireColumn.AutoFit
    End If
        
    If Say3 > 0 Then
        Worksheets("Liste3").Range("A1:E1") = Array("FİRMA", "P.NO", "KALIP", "MM", "RENK")
        Worksheets("Liste3").Range("A2").Resize(Say3, 5) = List3
        Worksheets("Liste3").Columns("A:E").EntireColumn.AutoFit
    End If
    Erase List1: Erase List2: Erase List3: Erase Veri
    Set Dict1 = Nothing: Set Dict2 = Nothing: Set Dict3 = Nothing
    Say1 = Empty: Say2 = Empty: Say3 = Empty: i = Empty: Son = Empty
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

İremeylul · 8 Aralık 2021

İlginiz ve desteğiniz için teşekkür ederim.
Object doesn’t support this property or method hatası alıyorum.
kodu çalıştıramadım.

ÖmerFaruk · 8 Aralık 2021

Ben dosyanızı deneyerek ve sorun olmadığını görerek paylaştım.
Kodları F8 tuşu ile adım adım çalıştırarak hata veren satırı söyler misin

İremeylul · 8 Aralık 2021

F8 ile devam ettirdiğimde

sort.sortfields.Add2 key:=range(A1:A” &

devam eden satırda hata vermektedir

ÖmerFaruk · 8 Aralık 2021

O ve altındaki diğer 2 satırda
.Sort.SortFields.Add2 Key:
kısımlarındaki Add2 yerine Add olarak denermisiniz?

Koşula göre bir sonraki satırları kontrol ederek yinelenenleri kaldırma

İremeylul

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

İremeylul

ÖmerFaruk

Destek Ekibi

Ekli dosyalar

İremeylul

ÖmerFaruk

Destek Ekibi

İremeylul

ÖmerFaruk

Destek Ekibi