skt tarihine göre stok tablonun konsolide edilmesi

[erteoz]

ekteki tabloda da görüleceği gibi, herbiri ayrı sheetlere işlenmiş gerçekte yaklaşık 40 bayinin, 300 çeşit ürün stoklarının takibi için son kullanma tarihi (SKT) bilgisini içeren stok tablolarını topladıktan sonra, yine çalışma tablosunda "genel toplam" olarak belirtilen sheet üzerinde, tüm bayilerin toplam stok bilgisini ürün çeşidi bazında, SKT'yide görecek şekilde düzenlemek istiyorum. Genellikle her bayiden en fazla 3 tane ayrı SKT'li ürün gelebiliyor. Ancak bu işlemi toplayarak yapınca inanılmaz uzun sürüyor. Bu işlemi nasıl çok daha kısa yapabileceğimle ilgili önerisi olan varsa yardımlarınızı bekliyorum, şimdiden teşekkürler,
Saygılarımla,

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları standart bir modul sayfasına kopyalayınız.

Option Explicit
Sub Genel_Toplam()
Dim sh As Worksheet
Dim shg As Worksheet
Dim i%, j%, y%, z%, n%, k%, satir%, sutun%
Dim col As New Collection
Dim arrV(), arrT()
Dim bul As Range
On Error Resume Next
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "GENEL TOPLAM" Then
        For i = 3 To sh.Cells(65536, 1).End(xlUp).Row
            col.Add sh.Cells(i, 1), sh.Cells(i, 2)
            If Err.Number = 0 Then
                y = y + 1
                ReDim Preserve arrV(1 To 2, 1 To y)
                arrV(1, y) = sh.Cells(i, 1)
                arrV(2, y) = sh.Cells(i, 2)
            End If
            Err.Number = 0
        Next i
    End If
Next
y = 0
On Error GoTo 0
Set shg = Sheets("GENEL TOPLAM")
With shg
    .Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).ClearContents
    .Range("A3").Resize(UBound(arrV, 2), UBound(arrV, 1)) = Application.WorksheetFunction.Transpose(arrV)
End With
On Error Resume Next
For i = 3 To shg.Cells(65536, 1).End(xlUp).Row
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shg.Name Then
            Set bul = sh.Columns(1).Find(sh.Cells(i, 1), Lookat:=xlWhole)
            If Not bul Is Nothing Then
                satir = bul.Row
                For j = 4 To sh.UsedRange.Columns.Count Step 2
                    For k = 4 To shg.UsedRange.Columns.Count Step 2
                        If sh.Cells(satir, j) <> Empty Then
                            If sh.Cells(satir, j) = shg.Cells(i, k) Then: z = z + 1
                        End If
                    Next k
                
                    If z = 0 Then
                        sutun = shg.Range("IV" & i).End(xlToLeft).Column + 1
                        shg.Cells(i, sutun) = sh.Cells(satir, j - 1)
                        shg.Cells(i, sutun + 1) = sh.Cells(satir, j)
                    Else
                        For n = 4 To shg.UsedRange.Columns.Count Step 2
                            If sh.Cells(satir, j) = shg.Cells(i, n) Then: Exit For
                        Next
                        shg.Cells(i, n - 1) = sh.Cells(satir, j - 1) + shg.Cells(i, n - 1)
                    End If
                    z = 0
                Next j
            End If
        End If
    Next
Next i
On Error GoTo 0
End Sub

Ekteki dosyayı inceleyiniz.

 

[erteoz]

Ferhat Bey,
İlginiz için çok teşekkür ederim, ellerinize sağlık, ancak, maalesef kodların nasıl kullanıldığıyla ilgili hiç bilgim olmadığı için sormak zorundayım, değerli vaktinizi harcayarak hazırladığınız bu kodları nasıl modül sayfasına kopyalamam gerektiğiyle ilgili eğer çok zor değilse sizden bilgi alabilirmiyim? yada sadece excel fonksiyonlarını kullanarak yapılacak bir yol biliyormusunuz?
tekrar teşekkür ederim,
Saygılarımla,

 

[Ferhat Pazarçevirdi]

Önceki mesajımın en altına bir zip dosyası ekledim. Evvela, onu açın.

"GENEL TOPLAM" sayfasına gelin ve oradaki Düğmeye basın.

 

[erteoz]

Ferhat Bey,
bayağı uğraştım sonunda hallettim, sayenizde birde makrodan bişeyler gördüm süper oldu çok teşekkür ederim ellerize sağlık
saygılarımla,