Kesim ve kalan adetlerini çekme

[tahsinanarat]

Gönderdiğim örnek dosyada;
A ve C sutunundaki aynı olanların ilk satırına
A VE C sütunundaki değerlere göre M sütununa, Stok sayfasındaki J sütunundaki değerin
A VE C sütunundaki değerlere göre N sütununa, Stok sayfasındaki M sütunundaki değerin

"database" sayfasının M VE N Sutunlarına gelmesi gereken sayıları manuel olarak yazdım.

Her değişkenin ilk satırına Makro ile getirilmesini yapmak istiyorum, benim yaptığımda aynı olan bütün satırlara getirebildim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Sub ADET_GÜNCELLE()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul As Range, Adres As String, Zaman As Double
    Dim X As Long, Son As Long, Veri_A As String, Veri_B As String
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = 0
    
    Set S1 = Sheets("database")
    Set S2 = Sheets("STOK")
    
    S1.Range("M2:N" & S1.Rows.Count).ClearContents
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    For X = 2 To Son
        If S1.Cells(X, 1) <> "" Then
            Veri_A = S1.Cells(X, 1) & S1.Cells(X, 3)
            If Veri_A <> Veri_B Then
                Set Bul = S2.Range("H:H").Find(S1.Cells(X, 1), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If Bul.Offset(0, 1) = S1.Cells(X, 3) Then
                            S1.Cells(X, 13) = S2.Cells(Bul.Row, 10)
                            S1.Cells(X, 14) = S2.Cells(Bul.Row, 13)
                            Veri_B = S1.Cells(X, 1) & S1.Cells(X, 3)
                            Exit Do
                        End If
                        Set Bul = S2.Range("H:H").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        End If
    Next
    
    Application.ScreenUpdating = 1
    Application.Calculation = 1
    
    MsgBox "İşlemininiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00"), vbInformation
End Sub

 

[numan şamil]

yanlış oldu

 

[tahsinanarat]

Sn. Korhan hocam eline koluna sağlık cevabın için çok teşekkür ederim. Orijinal dosyada 4100 satırlık database verisinde denedim 1,5 dk sürüyor, Hızlandırmak için bir şey yapılabilirmi, olmazsa da bu şekilde kullanacağız. Teşekkürler.

 

[Ömer BARAN]

Merhaba.

Alternatif: formül çözümünün makro ile uygulanması şeklindeki çözüm önerisidir.
NOT: database sayfası AA ve AB sütununun boş / işlemlerde kullanılmadığını varsaydım.
.

[B]Sub BARAN()[/B]
Set st = Sheets("STOK"): Set Db = Sheets("database")
dbson = Db.Cells(Rows.Count, 1).End(3).Row
stson = st.Cells(Rows.Count, 14).End(3).Row
If dbson > 1 Then Db.Range("M2:N" & dbson).ClearContents
Zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
With Db.Range("AA2:AA" & dbson)
    .Formula = "=A2&C2": .Value = .Value
End With
With Db.Range("AB2:AB" & dbson)
    .Formula = "=IF(COUNTIF($AA$2:$AA2,A2&C2)=1,""x"","""")": .Value = .Value
End With
Db.Range("A1:AB1").AutoFilter Field:=28, Criteria1:="x"
[M2].Formula = "=IF(SUMPRODUCT((STOK!$H$1:$H$" & stson & "=$A2)*(STOK!$I$1:$I$" & stson _
            & "=$C2)*(ROW(STOK!$H$1:$H$" & stson & ")))=0,""[B][COLOR="Red"]YOK[/COLOR][/B]"",OFFSET(STOK!$J$1,SUMPRODUCT((STOK!$H$1:$H$" & stson _
            & "=$A2)*(STOK!$I$1:$I$" & stson & "=$C2)*(ROW(STOK!$H$1:$H$" & stson & ")))-1,0))"
[N2].Formula = "=IF(SUMPRODUCT((STOK!$H$1:$H$" & stson & "=$A2)*(STOK!$I$1:$I$" & stson _
            & "=$C2)*(ROW(STOK!$H$1:$H$" & stson & ")))=0,""[B][COLOR="red"]YOK[/COLOR][/B]"",OFFSET(STOK!$M$1,SUMPRODUCT((STOK!$H$1:$H$" & stson _
            & "=$A2)*(STOK!$I$1:$I$" & stson & "=$C2)*(ROW(STOK!$H$1:$H$" & stson & ")))-1,0))"
Db.Range("M2:N2").Copy: Db.Range("M2:N" & Db.Cells(Rows.Count, 1).End(3).Row).Select
ActiveSheet.Paste: Db.[M1].Activate
Db.AutoFilterMode = False: Db.Range("M2:N" & dbson).Calculate
Db.Range("AA1:AB" & dbson).ClearContents: Db.Range("M2:N" & dbson) = Db.Range("M2:N" & dbson).Value
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı." & Chr(10) & "İşlem süresi : " & Format(Timer - Zaman, "0.00"), vbInformation
[B]End Sub[/B]

 

[tahsinanarat]

Sn. Ömer hocam elinize sağlık. Zaman olarak 7,46 sn. lere düştü mükemmel. Bulamadıklarına #BAŞV! hatası yerine Bulunamadı yazdırabilir miyiz.

 

[Ömer BARAN]

Önceki cevabımda verdiğim kod'da değişiklik yaptım.
Sayfayı yenileyerek, yeni haliyle dener misiniz?

 

[tahsinanarat]

Sn. Ömer hocam çok teşekkür ederim, istediğim gibi oldu, elinize sağlık, hakkınızı helal edin.

 

[Ömer BARAN]

Estağfurullah, kolay gelsin.
İyi çalışmalar dilerim.

 

[Korhan Ayhan]

Tahsin bey,

Önerdiğim kodun hızlı sonuç vermesi gerekir. Önerdiğim koda küçük eklemeler yaptım tekrar dener misiniz?

 

[tahsinanarat]

Sn. Korhan hocam, Teşekkür ederim 20 sn. düştü, Bulunamayanlara da yok yazdırılmasını yapamadım.