Listeden Belli Kritere Gore Listeleme Yapmak

[mustafaine1]

Merhaba Arkadaslar, elimde bir liste var, bu listedeki c satirlarinda ki kriterlere gore sayfanin altina dogru listeleme yapmasini istiyorum, yani her kriteri kendi icinde ayri ayrida gormek istiyorum, listeme bi goz atarsaniz sevinirim.. Ve bahsettigim olay icin fikrinizi ve yol gostericiliginizi bekliyorum..

 

[Orion1]

Dosyanız ektedir.
Tam 1 saat uğraşmışım.

 

[mustafaine1]

Hemen inceliyorum Evren Hocam.. Heyecan yaptim harbiden

 

[mustafaine1]

Evren Hocam suan kodlarinizi incelemekteyim; 4 - 11 arasi range aldigimiz yerler var kodlarda bu listeye yeni satir ekledindiginde 4 / 12 arasi filan olmasi gerekir bunu int atamalariyla filan ayarlayabilirmiyiz yoksa, isi cok yokusa surdun mustafa en bastan beri al baska sayfada goster ayri ayri listelemeyi verdigim kodlardan faydalanabilirsin mi dersiniz ?

 

[Orion1]

Evren Hocam suan kodlarinizi incelemekteyim; 4 - 11 arasi range aldigimiz yerler var kodlarda bu listeye yeni satir ekledindiginde 4 / 12 arasi filan olmasi gerekir bunu int atamalariyla filan ayarlayabilirmiyiz yoksa, isi cok yokusa surdun mustafa en bastan beri al baska sayfada goster ayri ayri listelemeyi verdigim kodlardan faydalanabilirsin mi dersiniz ?

Evet bu proplem var.
Dediğiniz gibi en son satıra göre yapmak istedim ama oraya liste çıkarıyoruz.
Hangi liste asıl liste hangi liste kodların çıkradığı liste bunu kodlar algılayamaz .Ben C sütunua göre düşündüm.C sütununa gör e en son satırı bulmayı düşündüm.Çünkü ona göre listeleme yapıyoru ya en doğrusu o na göre son satrı bulmakl olurdu .Ama!!:
L sütunundan sonra bir sütununu en son satırına göre yaparsak olur.
Orada boş geçmeyen mutlaka içine değer yazılan bir sütun söyleyin.Ben ona göre son satır olayını bulayım.O sütununda DUA DATE verilerini girdiğiniz sütun olur gibi görünüyor ama siz bilirsiniz.İçine veri girilmedemn en son satırdaski o sütunu pas geçilirse asıl verilerde zarar görür.Çünkü ben o satıra göre daha önce kodlarla gelmiş olan listeyi silecem.Başka bir sayfada olsaydı tüm bu problemler olamayacaktı aslında .2side ayni sayfada olduğu için problem oluyor.Bazen bazı şeylerden feragat etmek gerekiyor.Yani hem karnım doysun,hemde pastam bitmesin olmuyor.
Siz isteseniz başka bir sayfaya atalım listeyi istersenizde ayni syafada dediğim aralıktan bir sütun söyleyin son satırı bulmak için bana.Ama bana sorarsanız başka bir sayfaya çıkaralım derim.

 

[mustafaine1]

Peki Evren hocam en sona bi satir eklesem ben ve hep acicagim satirlari o satirin onunden eklesem..

b3 satirinada =COUNTIF(B4:B11,"<>0")+6 yazsak, yani b11 suanki benim hep onune satir ekleyecegim satir olsa b3 bu formulle 14 vercektir ve her satir ekledigimde 15.16.17... diye devam edecektir yani burda a14 ayristirilmis listeyi yapiyoruz yaa a b3 degerinden filan yapamazmiyiz acaba.. Ben cok ugrastim fakat surekli sorun aldim bu sekildede siz benden katkat daha iyisiniz boyle bir fikirle olabilirmi diye size sormadan yeni sayfayla ugrasmayayim, cevabinizi bekliyorum saygilar..

 

[mustafaine1]

Sub dokum()
Dim i As Long, sat As Long, k As Range, adr As String, say As Long
Dim renk As Integer, satir As Long, tss As Long, j As Byte, hcr As Range
Sheets("Numbers").Select
Application.ScreenUpdating = False
sat = Cells(65536, "A").End(xlUp).Row
tss = [b3].Value
If sat < tss Then GoTo atla
Range("A" & tss & ":M" & sat).Clear
Range("A" & tss & ":M" & sat).Interior.Color = vbBlack
atla:
sat = Cells(65536, "C").End(xlUp).Row
satir = tss
For i = 4 To tss - 3
    If WorksheetFunction.CountIf(Range("C2:C" & i), Cells(i, "C").Value) = 1 Then
        Set k = Range("C" & i & ":C" & sat).Find(Cells(i, "C").Value, , xlValues, xlWhole)
        say = say + 1
        If say Mod 2 = 0 Then
            renk = 10
            Else
            renk = 55
        End If
        Cells(satir, "A").Value = Cells(i, "C").Value
        Cells(satir, "A").Font.ColorIndex = 33
        Cells(satir, "A").Font.Bold = True
        Cells(satir, "A").Font.Size = 8
        'Cells(satir, "A").Borders.LineStyle = 1
    Cells(satir, "A").Borders(xlDiagonalDown).LineStyle = xlNone
    Cells(satir, "A").Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Cells(satir, "A").Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = renk
    End With
    With Cells(satir, "A").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Cells(satir, "A").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Cells(satir, "A").Borders(xlDiagonalDown).LineStyle = xlNone
   Cells(satir, "A").Borders(xlDiagonalUp).LineStyle = xlNone
    With Cells(satir, "A").Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Cells(satir, "A").Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = renk
    End With
    With Cells(satir, "A").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Cells(satir, "A").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = renk
    End With
    'Cells(satir, "A").Borders(xlEdgeRight).LineStyle = xlNone
        satir = satir + 1
        Cells(satir, "A").Value = "REFERENCE"
        Cells(satir, "B").Value = "INV DATE"
        Cells(satir, "C").Value = "VESSEL"
        Cells(satir, "D").Value = "B/L DATED"
        Cells(satir, "E").Value = "C/P DATE"
        Cells(satir, "F").Value = "LOAD&#221;NG"
        Cells(satir, "G").Value = "DISCHARGING"
        Cells(satir, "H").Value = "VAC CGO QTY"
        Cells(satir, "I").Value = "AIR CGO QTY"
        Cells(satir, "J").Value = "CGO"
        Cells(satir, "K").Value = "MESSRS"
        Cells(satir, "L").Value = "DUE DATE"
        Range("A" & satir & ":L" & satir).Interior.ColorIndex = renk
        Range("A" & satir & ":L" & satir).Font.ColorIndex = 2
        Range("A" & satir & ":L" & satir).Font.Bold = True
        Range("A" & satir & ":L" & satir).Font.Size = 8
        satir = satir + 1
        If Not k Is Nothing Then
            adr = k.Address
            Do
        Cells(satir, "A").Value = "'" & Cells(k.Row, "A").Value
        Cells(satir, "B").Value = Cells(k.Row, "D").Value
        Cells(satir, "C").Value = Cells(k.Row, "E").Value
        Cells(satir, "D").Value = Cells(k.Row, "F").Value
        Cells(satir, "E").Value = Cells(k.Row, "G").Value
        Cells(satir, "F").Value = Cells(k.Row, "H").Value
        Cells(satir, "G").Value = "DISCHARGING"
        Cells(satir, "H").Value = Cells(k.Row, "J").Value
        Cells(satir, "I").Value = Cells(k.Row, "K").Value
        Cells(satir, "J").Value = Cells(k.Row, "L").Value
        Cells(satir, "K").Value = Cells(k.Row, "M").Value
        Cells(satir, "L").Value = Cells(k.Row, "O").Value
        'Range("A" & satir & ":L" & satir).Interior.ColorIndex = renk
        Range("A" & satir & ":L" & satir).Font.ColorIndex = 2
        Range("A" & satir & ":L" & satir).Font.Bold = True
        Range("A" & satir & ":L" & satir).Font.Size = 8
        For Each hcr In Range("A" & satir & ":L" & satir)
            Z = renklen(hcr, renk)
        Next
        Set k = Range("C4:" & "C" & tss - 3).FindNext(k)
        satir = satir + 1
        Loop While Not k Is Nothing And k.Address <> adr
        End If
    End If
Next
Application.ScreenUpdating = True
MsgBox "Dokum Alindi." & vbLf & vbLf & "Hadi Yine Iyisin!!!", vbOKOnly + vbInformation, "S O N U C"
End Sub

Evren Hocam b3 satirina count if yaptirarak ve tss diye bi sayi atamasi daha yaparak kodunuzu duzenledim ve satir eklendigindede sorun cikartmamasini sagladim size ne kadar tesekkur etsem azdir sanirim, cok buyuk emek verdiniz size borclu adlediyorum kendimi cok sagolun..

 

[Orion1]

Ben şöyle bir çözüm buldum.
Bir bakın bakalım.Dosya ektedir.