Ürün ve parça listesi

[cevax]

Arkadaşlar 70 den fazla ürün ve 2000 den fazla parçanın stoklanması ve listelenmesi hakkında yardımıza ihtiyacım var.

Sorun şu parçanın karşısında kaç üründe kullanılıyorsa her urun bır sutunda olacak şeklinde listeye yerleimesini istiyorum nasıl yapabilirim.

ornek dosya ektedir.
şimdiden teşekkür ederim



https://1drv.ms/x/s!AiW6r_A_-A9_mPFiNTWDNTBiQVHryA

 

[Ömer BARAN]

Merhaba.

-- Sayfa1 isimli sayfaya 1 adet Metin Kutusu/Şekil ekleyin,
-- Belgeniz açıkken ALT+F11 tuşlarına basarak VBA ekranını görüntüleyin,
-- Açılan VBA ekranında üstteki MENÜ kısmından INSERT => MODULEyi seçin,
-- Sağdaki boş alana aşağıdaki kod blokunu yapıştırın.
-- Sayfa1'e eklediğiniz Metin Kutusuna/Şekile fareyle sağ tıklayıp MAKRO ATAyı seçin,
-- Açılacak küçük ekranda PARCA_URUN_ESLEME makro adını seçerek işlemi onaylayın.

Artık eklediğiniz Metin Kutusuna/Şekile fareyle tıkladığınızda istenilen liste oluşturulacaktır.
.

[B][COLOR="blue"]Sub PARCA_URUN_ESLEME()[/COLOR][/B]
Set s1 = Sheets("Sayfa1"): Set pl = Sheets("Parça listesi")
If MsgBox("Parça Listesi isimli sayfada mevcut bilgiler silinerek" & vbLf & _
    "Parça ve bu parçaların kullanıldığı ürün listesi yenilenecek." & vbLf & vbLf & _
    "İşlemi onaylıyor musunuz?", vbCritical + vbYesNo, "..::.. Ömer BARAN ..::..") = vbYes Then
zaman = Timer: pl.Cells.Clear: pl.Cells.UnMerge: pl.[B1] = "PARÇA"
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For s = 2 To s1.Cells(Rows.Count, 2).End(3).Row
    If WorksheetFunction.CountIf(s1.Range(s1.Cells(2, 3), s1.Cells(s, 3)), s1.Cells(s, 3)) = 1 Then
        plsat = pl.Cells(Rows.Count, 2).End(3).Row + 1
        pl.Cells(plsat, 2) = s1.Cells(s, 3)
        padet = padet + 1
        For ss = s To s1.Cells(Rows.Count, 2).End(3).Row
            If WorksheetFunction.CountIf(pl.Range(pl.Cells(plsat, 2), _
                pl.Cells(plsat, Columns.Count)), s1.Cells(ss, 2)) = 0 And _
                s1.Cells(ss, 3) = s1.Cells(s, 3) Then
                plsut = pl.Cells(plsat, Columns.Count).End(xlToLeft).Column + 1
                pl.Cells(plsat, plsut) = s1.Cells(ss, 2)
                If pl.Cells(plsat, plsut).End(3).Row = 1 Then
                    pl.Cells(1, plsut) = plsut - 2 & ". ÜRÜN"
                End If
            End If
        Next
    End If
Next
sonsat = pl.Cells(Rows.Count, 2).End(3).Row
sonsut = pl.Cells(1, Columns.Count).End(xlToLeft).Column
pl.Range(pl.[B1], pl.Cells(1, sonsut)).Font.Bold = True
pl.Range(pl.[B1], pl.Cells(sonsat, sonsut)).Borders.LineStyle = xlContinuous
pl.Range(pl.[B1], pl.Cells(1, sonsut)).Interior.ColorIndex = 15
fazla = pl.Cells(pl.Cells(sonsat + 1, sonsut).End(3).Row, 2)
pl.Columns.AutoFit
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı." & vbLf & "İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye." _
        & vbLf & vbLf & "Listelenen parça adeti: " & padet - 1 & vbLf & _
        "En fazla üründe kullanılan parça kodu: " & fazla, vbInformation, "..:: Ömer BARAN ::.."
    pl.Activate
Else
    MsgBox "Parça Listesi sayfasında herhangi bir işlem yapılmadı.", vbInformation, "..:: Ömer BARAN ::.."
End If
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
[B][COLOR="Blue"]End Sub[/COLOR][/B]

 

[cevax]

teşekkür ederim elinize sağlık hemen deneyeceğim