Ürün ve parça listesi

Katılım
4 Mart 2012
Mesajlar
21
Excel Vers. ve Dili
2010
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

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.
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.
.
Kod:
[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]
 
Katılım
4 Mart 2012
Mesajlar
21
Excel Vers. ve Dili
2010
teşekkür ederim elinize sağlık hemen deneyeceğim
 
Üst