Makro ile cok kiriterli duseyara

[canburak]

Busefer ekledim sanirim

 

[canburak]

Ben belgeyi hatırlıyorum ama ulaşılması gereken sonucun nasıl bulunacağı/neye göre bulunacağı kafamda netleşmiyor malesef.

Belirtmiştim ama unuttunuz anlaşılan, örnek belgenizde;
-- kulanılan kod yok,
-- ulaşılması gereken sonucu başka bir sütuna elle yazmanızı istemiştim ama o da yok.

Mevcut kodun bulduğu yanlış sonuç olan hücreyi renklendirerek işaretleyin ve olması gereken sonucu nasıl bulduğunuzu da açıklayarak örnek belgeyi yenileyin bence.
.

dosyayi ekledim sagtarafinada aciklama yazdim saygilar.

 

[Ömer BARAN]

Hala açıklama göremiyorum dosyada.

 

[canburak]

Hala açıklama göremiyorum dosyada.

hocam sari ile boyali yerlerin a sutunun da hepsinde kapali yazmasi lazim ayni numaraya B sutununda ait 2 adet CNT 1 adet kapali var , buna gore be sutununda c sutununa esit olan rakamda CNT olmayan varsa A sutununa b sutundaki Kapaliyi hem birincisine hem 2 cisinede yazmasi gerekiyor, suan calisma sekli c sutunundaki ayni olup ve B sutununda Cnt olan sutunun yanina kaali degerini getirmesi lazim

 

[canburak]

tekrar gonderiyorum Ustat

 

[Ömer BARAN]

Aşağıdaki gibi deneyin.
.

[B]Sub BUL()[/B]
Set c = Sheets("Contlist")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If c.Cells(Rows.Count, 1).End(3).Row > 1 Then c.Range("A2:A" & Rows.Count).ClearContents
For sat = 2 To c.Cells(Rows.Count, 2).End(3).Row
    If c.Cells(sat, 2) <> "CNT" Then
        c.Cells(sat, 1) = c.Cells(sat, 2)
        ilk = WorksheetFunction.Match(c.Cells(sat, 3), c.[C:C], 0)
        If WorksheetFunction.CountIf(c.[C:C], c.Cells(sat, 3)) > 1 Then
            For satt = 2 To c.Cells(Rows.Count, 2).End(3).Row
                If c.Cells(satt, 3) = c.Cells(ilk, 3) Then c.Cells(satt, 1) = c.Cells(sat, 1)
            Next
        End If
    End If
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
[B]End Sub[/B]

 

[canburak]

Aşağıdaki gibi deneyin.
.

[B]Sub BUL()[/B]
Set c = Sheets("Contlist")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If c.Cells(Rows.Count, 1).End(3).Row > 1 Then c.Range("A2:A" & Rows.Count).ClearContents
For sat = 2 To c.Cells(Rows.Count, 2).End(3).Row
    If c.Cells(sat, 2) <> "CNT" Then
        c.Cells(sat, 1) = c.Cells(sat, 2)
        ilk = WorksheetFunction.Match(c.Cells(sat, 3), c.[C:C], 0)
        If WorksheetFunction.CountIf(c.[C:C], c.Cells(sat, 3)) > 1 Then
            For satt = 2 To c.Cells(Rows.Count, 2).End(3).Row
                If c.Cells(satt, 3) = c.Cells(ilk, 3) Then c.Cells(satt, 1) = c.Cells(sat, 1)
            Next
        End If
    End If
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
[B]End Sub[/B]

Ustat elinize saglik cok guzel olmus Allah razi olsun hepinizden

 

[canburak]

Ustat birde ekde dosyada gonderiyorum, gelen parayi kapanan anlasmalara sifirlayarak ve kapana anlasmalari sifirladikdan sonra diger acik yani A sutunu bos olan a sutunun daki sutuna gore dagitarak gelen paranin rakamina gore esitlemesini saglaya bilirmiyiz acaba?