Aynı Ürünün Bedenlerini Karşı Sutuna Getirme

[neprotech_yazılım]

Merhabalar
Tekstil Sektörü İle İlgili Bir Çalışma Yapmamız Gerekiyor Örnek Olarak A Sutununda Ürün Kodları B Sutununda Bedenler Mevcut

A Sutunu B Sutunu

NP2020 S
NP2020 M
NP2020 L
NP2020 XL
NP2021 XS
NP2021 M
NP2021 L
NP2021 XL

Mevcut Verimiz Yukarıdaki Gibidir. Bunun Gibi 6.000 Satır Bulunmaktadır.

Bu Veriyi Aşağıda Belirtilen Hale Getirebilmemiz İçin Yardımlarınızı Rica Ederim.

NP2020 S M L XL
NP2020 S M L XL
NP2020 S M L XL
NP2020 S M L XL
NP2021 XS M L XL
NP2021 XS M L XL
NP2021 XS M L XL
NP2021 XS M L XL

Bu Veriyi Sağladıktan Sonra Aynı Verileri Kaldırıp

NP2020 S M L XL
NP2021 XS M L XL

Verisini Elde Etmek İstiyorum

 

[Murat OSMA]

Deneyiniz..

Sub Osma()
    Dim sd As Object, i&
    Set sd = CreateObject("Scripting.Dictionary")
    For i = 1 To Range("A65536").End(3).Row
        If Not sd.exists(Cells(i, 1).Value) Then
            sd.Add Cells(i, 1).Value, Cells(i, 2)
                Else
            sd.Item(Cells(i, 1).Value) = sd.Item(Cells(i, 1).Value) & "," & Cells(i, 2).Value
        End If
    Next i
    Range("C:D").ClearContents
    Range("C1").Resize(sd.Count, 1) = Application.Transpose(sd.keys)
    Range("D1").Resize(sd.Count, 1) = Application.Transpose(sd.Items)
    Set sd = Nothing: i = Empty
End Sub

 

[neprotech_yazılım]

Üstad Ellerinize Sağlık Ama Ben Bunu Excele Nasıl Ekleyeceğimi Bilmiyorum

 

[neprotech_yazılım]

Üstad Emeğinize Sağlık Çalıştı Beni Nasıl Büyük Bir Dertten Kurtardınız Allah Razı Olsun

 

[Murat OSMA]

Amin cümlemizden..

 

[neprotech_yazılım]

Üstad Aynı Formülü Farklı Excelde Uygulamaya Çalıştığımda Run Time Error 13 Hatası Alıyorum Neden Olabilir

 

[Korhan Ayhan]

Hata aldığınız dosyayı paylaşabilir misiniz?

 

[neprotech_yazılım]

İndir Milagron Son

Dosyayı indir Milagron Son

dosya.co

Buyrun Üstad

 

[Korhan Ayhan]

Rica etsem profilinizde yazan (test) ofis sürümü ve dilini değiştirebilir misiniz?

 

[neprotech_yazılım]

Değiştirdim Üstad

 

[Korhan Ayhan]

Paylaştığınız dosyanın hangi sayfasında hata alıyorsunuz?

 

[neprotech_yazılım]

Üstad İkinci Sayfasında Aynı İşelmi Yapmak İStiyorum Hata Alıyorum

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Bedenleri_Birlestir()
    Dim Dizi As Object, Veri As Variant, X As Long
    Dim Son As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
        
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = Range("A1:B" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 2)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 1), Say
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Veri(X, 2)
            Else
                Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) & "," & Veri(X, 2)
            End If
        End If
    Next
    
    If Say > 0 Then
        Range("C:D").Clear
        Range("C1").Resize(Say, 2) = Liste
        Cells.EntireColumn.AutoFit
    End If

    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[neprotech_yazılım]

Teşekkür Ederim Üstad Elinize Sağlık

 

[neprotech_yazılım]

Üstad Bir Hücre İçerisinde S,M,L,S,M,L Yazıyor Bunu S,M,L Verisine Nasıl Çeviririm

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Bedenleri_Birlestir()
    Dim Dizi As Object, Kontrol As Boolean, Beden As Variant, Veri As Variant
    Dim X As Long, Y As Long, Son As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
        
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = Range("A1:B" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 2)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 1), Say
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Veri(X, 2)
            Else
                Beden = Split(Liste(Dizi.Item(Veri(X, 1)), 2), ",")
                For Y = LBound(Beden) To UBound(Beden)
                    If Beden(Y) = Veri(X, 2) Then
                        Kontrol = True
                        Exit For
                    End If
                Next
                If Kontrol = False Then
                    Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) & "," & Veri(X, 2)
                End If
                Kontrol = False
            End If
        End If
    Next
    
    If Say > 0 Then
        Range("C:D").Clear
        Range("C1").Resize(Say, 2) = Liste
        Cells.EntireColumn.AutoFit
    End If

    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[neprotech_yazılım]

Çok Teşekkürler...

 

[neprotech_yazılım]

Üstad Son Olarak Bir Sorum Daha Olacak

NP2021 S
NP2021 M
NP2021 L
NP2021 XL

Verisinin Bedenlerin Yer Aldığı Sütunun Karşısına NP2021 Verisi İçin Kaçıncı Değer Olduğunu Yazmam Lazım

Örneğin;

NP2021 S 1.Değer
NP2021 M 2.Değer Gibi.

 

[Korhan Ayhan]

EĞERSAY ya da ÇOKEĞERSAY formüllerini araştırınız..