süzme ile rapor almak

[bravo64]

Arkadaşlar iyi akşamlar,
dosyamla ilgili çözüm yolu gösterecek varmı?
teşekkürler

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları inceleyiniz veya örnek dosyayı indiriniz.

Liste ve tabloların yerini değiştirmeyiniz. Makro kodları, çoğu zaman formüller kadar genel olmayabilir. Formüllerde bir satır ilave etmekle, formüller referanslarını otomatik olarak yenileyebilir. Ama makrolar, daha özel durumlar için yazıldığından, sayfa yapısının, saya ismini değişmesi halinde bile çalışmayabilirler.

Sub EnBuyuk_Pesinler()
Dim arrTeklif(), arrSecilen()
Dim EnB As Long, EnBInd As Integer
Dim sh As Worksheet
Set sh = Sheets("enbüyük3")
sh.Range("L3:N5").ClearContents
ReDim arrTeklif(1 To sh.Cells(65536, 1).End(xlUp).Row - 1, 1 To 3)
For i = 2 To sh.Cells(65536, 1).End(xlUp).Row
    For j = 1 To 3
        arrTeklif(i - 1, j) = sh.Cells(i, j)
    Next j
    If Application.WorksheetFunction.CountIf(sh.Range("C2:C" & i), sh.Cells(i, 3)) = 1 Then: z = z + 1
Next i
ReDim arrSecilen(1 To 3, 1 To 3)
For y = 1 To 3
    EnB = arrTeklif(1, 2)
    EnBInd = 1
    For i = 1 To UBound(arrTeklif)
        If arrTeklif(i, 2) > EnB Then
           EnB = arrTeklif(i, 2)
           EnBInd = i
        End If
    Next i
    For i = 1 To UBound(arrSecilen)
        If arrSecilen(i, 3) = arrTeklif(EnBInd, 3) Then: x = x + 1
    Next i
    If x = 0 Then
       arrSecilen(y, 1) = arrTeklif(EnBInd, 1)
       arrSecilen(y, 2) = arrTeklif(EnBInd, 2)
       arrSecilen(y, 3) = arrTeklif(EnBInd, 3)
       arrTeklif(EnBInd, 1) = 0:   arrTeklif(EnBInd, 2) = 0:   arrTeklif(EnBInd, 3) = 0
    Else
       If z < 3 And y = 3 Or UBound(arrTeklif) <= 3 Then
          GoTo f1
       End If
       arrTeklif(EnBInd, 1) = 0:   arrTeklif(EnBInd, 2) = 0:   arrTeklif(EnBInd, 3) = 0
       y = y - 1
    End If
    x = 0
Next y
f1:
sh.Cells(3, "L").Resize(3, 3) = arrSecilen
Set sh = Nothing
End Sub
Sub Enbuyuk_Vadeliler()
Dim arrTeklif(), arrSecilen()
Dim EnB As Long, EnBInd As Integer
Dim sh As Worksheet
Set sh = Sheets("enbüyük3")
sh.Range("Q3:S5").ClearContents
ReDim arrTeklif(1 To sh.Cells(65536, 5).End(xlUp).Row - 1, 1 To 3)
For i = 2 To sh.Cells(65536, 5).End(xlUp).Row
    For j = 1 To 3
        arrTeklif(i - 1, j) = sh.Cells(i, j + 4)
    Next j
    If Application.WorksheetFunction.CountIf(sh.Range("G2:G" & i), sh.Cells(i, 7)) = 1 Then: z = z + 1
Next i
ReDim arrSecilen(1 To 3, 1 To 3)
For y = 1 To 3
    EnB = arrTeklif(1, 2)
    EnBInd = 1
    For i = 1 To UBound(arrTeklif)
        If arrTeklif(i, 2) > EnB Then
           EnB = arrTeklif(i, 2)
           EnBInd = i
        End If
    Next i
    For i = 1 To UBound(arrSecilen)
        If arrSecilen(i, 3) = arrTeklif(EnBInd, 3) Then: x = x + 1
    Next i
    If x = 0 Then
       arrSecilen(y, 1) = arrTeklif(EnBInd, 1)
       arrSecilen(y, 2) = arrTeklif(EnBInd, 2)
       arrSecilen(y, 3) = arrTeklif(EnBInd, 3)
       arrTeklif(EnBInd, 1) = 0:   arrTeklif(EnBInd, 2) = 0:   arrTeklif(EnBInd, 3) = 0
    Else
       If z < 3 And y = 3 Or UBound(arrTeklif) <= 3 Then
          GoTo f1
       End If
       arrTeklif(EnBInd, 1) = 0:   arrTeklif(EnBInd, 2) = 0:   arrTeklif(EnBInd, 3) = 0
       y = y - 1
    End If
    x = 0
Next y
f1:
sh.Cells(3, "Q").Resize(3, 3) = arrSecilen
Set sh = Nothing
End Sub

 

[bravo64]

sayın FPC çok teşekkür ederim.Ve şunuda söylemek isterim ki;amacım sizin hazırladığınız kodları kopyalayıp işimizi halletmek asla değil.her yeni kodda yeni şeylerde öğrenip başka uygulamalar da da adapte edebilmek.Bu hazırladığınız kodu forumda hiç rastlamadım.okunma sayısı ve cevaplama sayısındaki orandan anlaşılabilir bu.Onun için ısrarlı mesajlarımı yanlış anlamadığınızı umuyorum.benim gibi birçok öğrenciye yol göstereceğini düşünüyorum.Emeğinize ve bilginize sağlık.
En içten saygılarımla..
M.Acar