Iller bazında ürün takip

[ocak26]

Merhaba arkadaşlar.
Ekli tabloda iller bazı ürün takip olarak bir tablo yaptım.
Ekli listede gösterdiğim gibi mevcut tabloyu listeye dönüştürmek istiyorum.
çok teşekkür ederim.

 

[Ömer BARAN]

Merhaba.

Alt taraftan Sayfa1'in adına fareyle sağ tıklayıp ve KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranının sağ tarafındaki boş alana aşağıdaki kod'u yapıştırın ve VBA ekranını kapatın.

Sayfa1'e bir ŞEKİL, METİN KUTUSU veya DÜĞME ekleyin ve eklediğiniz bu şekle/metin kutusuna
fareyle sağ tıklayıp MAKRO ATAyı seçin, açılacak küçük ekranda Sayfa1SIRALA adını seçip TAMAMı tıklayın.

Artık bu düğmeye tıkladığınızda istediğiniz işlem gerçekleşecektir.
.

[FONT="Arial Narrow"][B][COLOR="blue"]Sub SIRALA()[/COLOR][/B]
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
s1.Activate: s2.Range("A:C").ClearContents
s2.Range("B:B").Interior.Color = xlNone
For sat = 3 To s1.[A65536].End(3).Row
    For sut = 4 To 10
        s1.Cells(sat, sut) = Trim(s1.Cells(sat, sut))
        s2.Cells(s2.[C65536].End(3).Row + 1, 3) = Trim(s1.Cells(sat, sut))
    Next
Next
    s2.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    For s2satır = 2 To s2.[C65536].End(3).Row
    s2.Cells(s2.[B65536].End(3).Row + 1, 2) = s2.Cells(s2satır, 3)
    s2.Cells(s2.[B65536].End(3).Row, 2).Interior.Color = vbYellow
        For s1satır = 3 To s1.[A65536].End(3).Row
            If WorksheetFunction.CountIf(s1.Range(Cells(s1satır, 4), Cells(s1satır, 10)), _
                s2.Cells(s2satır, 3)) > 0 Then
                s2ss = s2.[B65536].End(3).Row + 1
                s2.Cells(s2ss, 1) = s1.Cells(s1satır, 2): s2.Cells(s2ss, 2) = s1.Cells(s1satır, 3)
            End If
        Next
    Next
s2.Range("C:C").ClearContents: MsgBox "İşlem Tamamlandı": s2.Activate
[B][COLOR="blue"]End Sub[/COLOR][/B][/FONT]

 

[ocak26]

Ömer Bey Çok Teşekkür ederim...
Elinize ve emeğinize sağlık...