Plaka Ve Giderleri Listeleme

[excelistan]

Data sayfasında A sütununda "KOD", B sütununda "İL", C sütununda da bu ildeki araçların "PLAKA"ları var.

Örnekte de görüleceği gibi, ben kodu yazdığımda bu kodun ait olduğu ilin adı ve bu ildeki araç plakalarının otomatik olarak gelmesini istiyorum.

İl adı ve araç plakaları bitince de "GİDER SINIFI" diye adlandırdığım hücrelerin sabit olarak hemen altındaki satırlara yerleşmesini istiyorum.

Yardımlarınız için şimdiden teşekkür ederim.

 

[Necdet]

Merhaba,

Gider Sınıfını anlamadım.

Aşağıdaki kodların "ÖRNEK" sayfasına kopyalamanız gerek.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [C3]) Is Nothing Then Exit Sub
Set sd = Sheets("DATA")
Dim i As Long, j As Long
Application.ScreenUpdating = False
Range("E3:E65000, G3:G65000").ClearContents
Set Bul = sd.Columns(1).Find(Target.Value)
If Not Bul Is Nothing Then
        MsgBox Bul.Row
        j = 3
        i = Bul.Row
        Do
            Cells(j, "E") = sd.Cells(i, "B")
            Cells(j, "G") = sd.Cells(i, "C")
            i = i + 1
            j = j + 1
        Loop Until sd.Cells(i, "A") <> Target.Value
End If
Son:
Application.ScreenUpdating = True
End Sub

 

[excelistan]

Necdet Bey saolun,1. aşama olmuş. Kodu yazdığımda ili adı, ve o ilde bulunan araçların plakaları geliyor.

2. aşamada il adı ve plakaların sonlandığı satırdan sonra, gider sınıfı diye adlandırdığım hücrelerin aynen yerleşmesini istiyorum. Yani il adı ve plaka bitiminden sonraki satıra şu hücrelerin gelmesini istiyorum;

GİDER SINIFI
......................YAKIT........111
......................YAĞ...........222
......................SİGORTA....333
......................DİĞER........444


Bir de msgboxı kaldırırsanız memnun olurum.

 

[Necdet]

Merhaba,

Kodlardaki değişiklik koyu olarak gösterilmiştir.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [C3]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Set sd = Sheets("DATA")
Dim i As Long, j As Long
Application.ScreenUpdating = False
Range("E3:G65000").ClearContents
Set Bul = sd.Columns(1).Find(Target.Value)
If Not Bul Is Nothing Then
        j = 3
        i = Bul.Row
        Do
            Cells(j, "E") = sd.Cells(i, "B")
            Cells(j, "G") = sd.Cells(i, "C")
            i = i + 1
            j = j + 1
        Loop Until sd.Cells(i, "A") <> Target.Value
        
[B][COLOR=red]        Cells(j, "F") = "YAKIT"
        Cells(j, "G") = 111
        j = j + 1
        Cells(j, "F") = "YAĞ"
        Cells(j, "G") = 222
        j = j + 1
        Cells(j, "F") = "SİGORTA"
        Cells(j, "G") = 333
        j = j + 1
        Cells(j, "F") = "DİĞER"
        Cells(j, "G") = 444
[/COLOR][/B]End If
Son:
Application.ScreenUpdating = True
End Sub

 

[excelistan]

Necdet Bey kusura bakmayın, anlatamadım. 2. aşamada il adı ve plakaların sonlandığı satırdan sonra, gider sınıfı diye adlandırdığım hücrelerin aynen yerleşmesini istiyorum. Gider sınıfı diye adlandırdığım hücreler 1. örneğimde E9:G12 , 2.örneğimde ise E24:G27'dir.

Emeğiniz için teşekkür ederim.

 

[tahsinanarat]

Necdet hocamın kodları

Necdet hocamın ilave ettiği kodlar istediğinizi yapıyor, hocamın kodlarına saadece illerin bittiği satıra GİDER SINIFI ialve edilmiştir.

 

[Necdet]

Merhaba,

Sanırım Gider Kalemlerinin aynı kalmasını istiyor arkadaşımız. Eğer böyle ise :

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [C3]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Set sd = Sheets("DATA")
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set Bul = sd.Columns(1).Find(Target.Value)
If Not Bul Is Nothing Then
    Sat = [E65536].End(3).Row
    Range("E" & Sat & ":G" & Sat + 3).Copy [IT1]
    Range("E3:G65000").Clear
    j = 3
    i = Bul.Row
    Do
        Cells(j, "E") = sd.Cells(i, "B")
        Cells(j, "G") = sd.Cells(i, "C")
        i = i + 1
        j = j + 1
    Loop Until sd.Cells(i, "A") <> Target.Value
    Range("IT1:IV4").Copy Range("E" & j)
    Range("IT1:IV4").Clear
End If
Son:
Application.ScreenUpdating = True
End Sub

 

[excelistan]

Necdet bey son dosyadaki tam istediğim gibi olmuş.

İkinizden de Allah razı olsun. Hem işim görülmüş oldu, hem de çok önemli bir makroyu öğrenmiş oldum.

En içten sevgi ve saygılarımla, sağlıcakla kalın.

 

[Necdet]

Güle güle, iyi günlerde kullanınız.