Liste oluşturmak

[tar23]

selam arkadaşlar,
bir sorunum var bir liste hazırlamam gerekiyor bu listede firmalardan gelen faturalar satır satır girilmiş durumda fakat belirli bir limitin üstünde olan firmalara ait tüm fatura satırlarını ayrı bir tabloda belirtmem gerekiyor yardımlarınızı bekliyorum. hazırladımım küçük bir dosya ektedir.

 

[Orion1]

Dosyanız ektedir.

Sub limit()
Dim sat As Long, i As Long, k As Range, adr As String, sh As Worksheet, sat2 As Long
Sheets("Sayfa1").Select
Set sh = Sheets("LİSTE")
If Not IsNumeric(Range("B1").Value) Then
    MsgBox "Limit sayısal bir değer olmalıdır." & vbLf & "Rapor çıkarılmadı.", vbCritical, "UYARI"
    Range("B1").Select
    Exit Sub
End If
Application.ScreenUpdating = False
sh.Range("A4:J65536").ClearContents
sat = Cells(65536, "D").End(xlUp).Row
sat2 = 4
For i = 4 To sat
    If WorksheetFunction.CountIf(Range("D4:D" & i), Cells(i, "D").Value) = 1 Then
        If WorksheetFunction.SumIf(Range("D4:D" & sat), Cells(i, "D").Value, _
        Range("H4:H" & sat)) > Range("B1").Value Then
            Set k = Range("D4:D" & sat).Find(Cells(i, "D").Value, , xlValues, xlWhole)
            If Not k Is Nothing Then
                adr = k.Address
                Do
                    sh.Range("A" & sat2 & ":J" & sat2).Value = Range("A" & k.Row & ":J" & k.Row).Value
                    sat2 = sat2 + 1
                    Set k = Range("D4:D" & sat).FindNext(k)
                Loop While Not k Is Nothing And k.Address <> adr
            End If
        End If
    End If
Next i
sh.Select
Range("A4:J65536").Sort key1:=Range("D4"), key2:=Range("A4")
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[tar23]

Sayın Evren,
öncelikle ilginize teşekkür ederim fakat limitin üstündeki satırlar tekrarlanıyor oysa benim istediğim tüm satırların ayrı ayrı getirilmesi şeklinde olacaktı gözatarsanız sevinirim

 

[Orion1]

Sayın Evren,
öncelikle ilginize teşekkür ederim fakat limitin üstündeki satırlar tekrarlanıyor oysa benim istediğim tüm satırların ayrı ayrı getirilmesi şeklinde olacaktı gözatarsanız sevinirim

Pardon teknik bir arıza olmuş.
Düzenledim ve 2 numaralı mesajda ekledim.
Dosyayı oradan indirebilrisiniz.

 

[tar23]

Sayın Evren,
Çok teşekkür ederim emeğinize sağlık

 

[Orion1]

Sayın Evren,
Çok teşekkür ederim emeğinize sağlık

Rica ederim.
İyi çalışmalar.