• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Koşula Göre Değer Getirtmek

  • Konbuyu başlatan Konbuyu başlatan aLp59
  • Başlangıç tarihi Başlangıç tarihi
aLp59

aLp59

Altın Üye
Katılım
19 Kasım 2020
Mesajlar
70
Excel Vers. ve Dili
365 / İngilizce
Arkadaşlar merhaba

Depodan, ihtiyaç miktarına göre gönderilebilecek adetleri, lot ve raflarıyla birlikte getirtmek istiyorum.

Detaylı açıklamayı ekte anlatmaya çalıştım.

Şimdiden teşekkür ederim:)
 

Ekli dosyalar

Kodlar aşağıda.
Ayrıca excel dosyanızda ufak değişiklikler yaptım. Kodlar eklenmiş dosyanızı da ekliyorum, inceleyin.
C++: 
Sub RaporAl()
Dim SonA%, Ara As Range, Bul As Range
Dim KalanÜrün&, Kalanİhityac&, Verilen&
Dim xMax As Range, yMax As Range
Dim Zaman#
Zaman = Timer
Application.ScreenUpdating = False
SonJ = Range("J" & Rows.Count).End(3).Row
If SonJ < 2 Then SonJ = 2
Range("J2:N" & SonJ).ClearContents
Verilen = 0
x = 1
SonA = Range("A" & Rows.Count).End(3).Row
Range("B2:B" & SonA).Copy Range("E2:E" & SonA)
For i = 2 To Range("G" & Rows.Count).End(3).Row
    Set Ara = Range("G" & i)
    Kalanİhtiyac = Ara.Offset(0, 1).Value
    Do While Kalanİhtiyac > 0
        KalanÜrün = WorksheetFunction.SumIf(Range("A2:A" & SonA), Range("G" & i), Range("E2:E" & SonA))
        Set Bul = Range("A1:A" & SonA).Find(Ara, , , xlWhole)
        If Bul Is Nothing Then GoTo Devam1 'Stokta bu ürün yok diğer ürüne geç
        ilkadres = Bul.Address
        Select Case KalanÜrün - Kalanİhtiyac
            Case 0
                Do
                    If Bul.Offset(, 4) = Kalanİhtiyac Then
                        x = x + 1
                        Range("J" & x) = Bul.Value
                        Range("K" & x) = Kalanİhtiyac
                        Range("L" & x) = Bul.Offset(, 4)
                        Range("M" & x) = Bul.Offset(, 2)
                        Range("N" & x) = Bul.Offset(, 3)
                        Bul.Offset(, 4) = 0
                        GoTo Devam1 'Bu ürün tamamlandı diğer Ürüne geç
                    End If
                    Set Bul = Range("A1:A" & SonA).FindNext(Bul)
                Loop While Bul.Address <> ilkadres

            Case Is < 0
                Do
                    x = x + 1
                    Range("J" & x) = Bul.Value
                    Range("K" & x) = Kalanİhtiyac
                    Range("L" & x) = Bul.Offset(, 4)
                    Range("M" & x) = Bul.Offset(, 2)
                    Range("N" & x) = Bul.Offset(, 3)
                    Bul.Offset(, 4) = 0
                    Kalanİhtiyac = Kalanİhtiyac - Bul.Offset(, 4)
                    Set Bul = Range("A1:A" & SonA).FindNext(Bul)
                Loop While Bul.Address <> ilkadres
                GoTo Devam1 'Bu ürün tamamlandı diğer Ürüne geç

            Case Is > 0
                Set xMax = Bul
                Do
                    If Bul.Offset(, 4) >= xMax.Offset(, 4) And Kalanİhtiyac >= Bul.Offset(, 4) Then
                        Set xMax = Bul
                    ElseIf Bul.Offset(, 4) < xMax.Offset(, 4) And Kalanİhtiyac <= Bul.Offset(, 4) Then
                        Set xMax = Bul
                    End If
                    Set Bul = Range("A1:A" & SonA).FindNext(Bul)
                Loop While Bul.Address <> ilkadres
                x = x + 1
                Range("J" & x) = xMax.Value
                Range("K" & x) = Kalanİhtiyac
                Range("L" & x) = WorksheetFunction.Min(xMax.Offset(, 4), Kalanİhtiyac)
                Range("M" & x) = xMax.Offset(, 2)
                Range("N" & x) = xMax.Offset(, 3)
                xMax.Offset(, 4) = xMax.Offset(, 4) - Range("L" & x)
                Kalanİhtiyac = Kalanİhtiyac - Range("L" & x)
        End Select
        Loop
Devam1:
    Next i
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam" & Chr(10) & Chr(10) & "Süre = " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 

Ekli dosyalar

Üstadım

Değerleri değiştirip çalıştırdığımda kilitleniyor, var mıdır bir çözümü:)
 
Değerler aşağı doğru boş tekrar ediyor.



230018
 
Düzenledim.

C++: 
Sub RaporAl()
Dim SonA%, Ara As Range, Bul As Range
Dim KalanÜrün#, Kalanİhityac#, Verilen#
Dim xMax As Range, yMax As Range
Dim Zaman#
Zaman = Timer
Application.ScreenUpdating = False
SonJ = Range("J" & Rows.Count).End(3).Row
If SonJ < 2 Then SonJ = 2
Range("J2:N" & SonJ).ClearContents
Verilen = 0
x = 1
SonA = Range("A" & Rows.Count).End(3).Row
Range("B2:B" & SonA).Copy Range("E2:E" & SonA)
For i = 2 To Range("G" & Rows.Count).End(3).Row
    Set Ara = Range("G" & i)
    Kalanİhtiyac = Ara.Offset(0, 1).Value
    Do While Kalanİhtiyac > 0
        KalanÜrün = WorksheetFunction.SumIf(Range("A2:A" & SonA), Range("G" & i), Range("E2:E" & SonA))
        Set Bul = Range("A1:A" & SonA).Find(Ara, , , xlWhole)
        If Bul Is Nothing Then GoTo Devam1 'Stokta bu ürün yok diğer ürüne geç
        ilkadres = Bul.Address
        Select Case KalanÜrün - Kalanİhtiyac
            Case 0
                Do
                    If Bul.Offset(, 4) = Kalanİhtiyac Then
                        x = x + 1
                        Range("J" & x) = Bul.Value
                        Range("K" & x) = Kalanİhtiyac
                        Range("L" & x) = Bul.Offset(, 4)
                        Range("M" & x) = Bul.Offset(, 2)
                        Range("N" & x) = Bul.Offset(, 3)
                        Bul.Offset(, 4) = 0
                        GoTo Devam1 'Bu ürün tamamlandı diğer Ürüne geç
                    End If
                    Set Bul = Range("A1:A" & SonA).FindNext(Bul)
                Loop While Bul.Address <> ilkadres

            Case Is < 0
                Do
                    x = x + 1
                    Range("J" & x) = Bul.Value
                    Range("K" & x) = Kalanİhtiyac
                    Range("L" & x) = Bul.Offset(, 4)
                    Range("M" & x) = Bul.Offset(, 2)
                    Range("N" & x) = Bul.Offset(, 3)
                    Kalanİhtiyac = Kalanİhtiyac - Bul.Offset(, 4)
                    Bul.Offset(, 4) = 0
                    Set Bul = Range("A1:A" & SonA).FindNext(Bul)
                Loop While Bul.Address <> ilkadres
                GoTo Devam1 'Bu ürün tamamlandı diğer Ürüne geç

            Case Is > 0
                Set xMax = Bul
                Do
                    If Bul.Offset(, 4) > 0 And Bul.Offset(, 4) <= xMax.Offset(, 4) Then Set xMax = Bul
                    If xMax.Offset(, 4) = 0 Then Set xMax = Bul
                    Set Bul = Range("A1:A" & SonA).FindNext(Bul)
                Loop While Bul.Address <> ilkadres
                x = x + 1
                Range("J" & x) = xMax.Value
                Range("K" & x) = Kalanİhtiyac
                Range("L" & x) = WorksheetFunction.Min(xMax.Offset(, 4), Kalanİhtiyac)
                Range("M" & x) = xMax.Offset(, 2)
                Range("N" & x) = xMax.Offset(, 3)
                xMax.Offset(, 4) = xMax.Offset(, 4) - Range("L" & x)
                Kalanİhtiyac = Kalanİhtiyac - Range("L" & x)
        End Select
        Loop
Devam1:
    Next i
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam" & Chr(10) & Chr(10) & "Süre = " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Üstadım

Gayet güzel çalışıyor.

Çok teşekkür ederim.:)
 
Eyvalalh
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst