• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile cok kiriterli duseyara

  • Konbuyu başlatan Konbuyu başlatan canburak
  • Başlangıç tarihi Başlangıç tarihi
C

canburak

Katılım
30 Kasım 2011
Mesajlar
205
Excel Vers. ve Dili
Ofis 2016 Tr 64 Bit , Turkce
Merhabalar,
Assagida yazdigim formulu makro ile nasil yapabilirim yardimlariniz icin simdiden tesekkurler.
birde ek olarak Assagidaki formul Sayfa3 de ve A stununda calismasi lazim ve A sutunu bos olan hucrelere

=EĞERHATA(İNDİS($B:$B;KAÇINCI(1;($B:$B<>"CNT")*($C:$C=$C311);0);1);"")

"B" sutununda eger "CNT" ve "C" sutunu esit degilse degilse "A" sutununa "B" sutunundaki Hucreyi getirsin degilse bos biraksin assagidaki ornekdeki gibi. (B ve C sutunda verilervar A sutununda formulum var suanda yukardaki formulu kullaniyom ama cok yavasliyor o yuzden makro ile yapmak istiyorum.

-A- ____ -B- ____ -C_
kapat __ CNT ___ 70197
....... ___ CNT ___ 70198
kapat __ CNT ___ 70203
kapat __ CNT ___ 70205
kapat __ CNT ___ 70205
....... ___ CNT ___ 70208
iptal ___ CNT ___ 70207
kapat __ kapat __ 70197
kapat __ kapat __ 70203
kapat __ kapat __ 70205
iptal ___ kapat __ 70207
 

Ekli dosyalar

Son düzenleme:
123 kisi goruntulemis ama kimse yapamamismi cok mu zor bu sey , anlamadim bunu normalde formul olarak kullaniyom zaten ,
 
Merhaba.

Aşağıdaki gibi olabilir.
.
Kod: 
[B]Sub BUL()[/B]
If Cells(Rows.Count, 1).End(3).Row > 1 Then Range("A2:A" & Rows.Count).ClearContents
For sat = 2 To Cells(Rows.Count, 2).End(3).Row
    If Cells(sat, 2) <> "CNT" Then
        Cells(sat, 1) = Cells(sat, 2)
        Cells(WorksheetFunction.Match(Cells(sat, 3), [C:C], 0), 1) = Cells(sat, 2)
    End If
Next
[B]End Sub[/B]
 
Alternatif;

Kod: 
Sub kod_deneme()
a = Range("A2:C" & Cells(Rows.Count, 7).End(3).Row)
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        If a(i, 2) <> "CNT" Then
            d(a(i, 3)) = i
        End If
    Next i
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        b(i, 1) = a(d(a(i, 3)), 2)
    Next i
[A2].Resize(UBound(a)) = b
MsgBox "İşlem tamam....", vbInformation
End Sub
 
Ömer BARAN' Alıntı:
Merhaba.

Aşağıdaki gibi olabilir.
.
Kod: 
[B]Sub BUL()[/B]
If Cells(Rows.Count, 1).End(3).Row > 1 Then Range("A2:A" & Rows.Count).ClearContents
For sat = 2 To Cells(Rows.Count, 2).End(3).Row
    If Cells(sat, 2) <> "CNT" Then
        Cells(sat, 1) = Cells(sat, 2)
        Cells(WorksheetFunction.Match(Cells(sat, 3), [C:C], 0), 1) = Cells(sat, 2)
    End If
Next
[B]End Sub[/B]
Genişletmek için tıkla ...

Ustat elinize saglik super olmus cok tesekkurler
 
Ziynettin' Alıntı:
Alternatif;

Kod: 
Sub kod_deneme()
a = Range("A2:C" & Cells(Rows.Count, 7).End(3).Row)
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        If a(i, 2) <> "CNT" Then
            d(a(i, 3)) = i
        End If
    Next i
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        b(i, 1) = a(d(a(i, 3)), 2)
    Next i
[A2].Resize(UBound(a)) = b
MsgBox "İşlem tamam....", vbInformation
End Sub
Genişletmek için tıkla ...


Ustat sizinde elinize saglik super olmus 2 side isimi goruyor cok tesekkurler
 
tamamdir sorun yok calisiyor ,bazi seyleri silmisim ondanmis
 
Merhabalar tekrar, bu makro Baska sayfada ike n calistirmak istiyorum ama yapadim , ben sayfa 1 de iken, makro Sayfa5 de calismasini istiyorum
yardimlariniz icin tesekkurler
 
Ömer BARAN' Alıntı:
Merhaba.

Aşağıdaki gibi olabilir.
.
Kod: 
[B]Sub BUL()[/B]
If Cells(Rows.Count, 1).End(3).Row > 1 Then Range("A2:A" & Rows.Count).ClearContents
For sat = 2 To Cells(Rows.Count, 2).End(3).Row
    If Cells(sat, 2) <> "CNT" Then
        Cells(sat, 1) = Cells(sat, 2)
        Cells(WorksheetFunction.Match(Cells(sat, 3), [C:C], 0), 1) = Cells(sat, 2)
    End If
Next
[B]End Sub[/B]
Genişletmek için tıkla ...

Merhabalar tekrar, bu makro Baska sayfada ike n calistirmak istiyorum ama yapadim , ben sayfa 1 de iken, makro Sayfa5 de calismasini istiyorum
yardimlariniz icin tesekkurler
 
neyse sagolun sanirim cozdum olayi



Sub cntkapaliRus()
'cnt kapali



Set Contlist = Sheets("Contlist")

If Contlist.Cells(Rows.Count, 1).End(3).Row > 1 Then Contlist.Range("A2:A" & Rows.Count).ClearContents

For sat = 2 To Contlist.Cells(Rows.Count, 2).End(3).Row
If Contlist.Cells(sat, 2) <> "CNT" Then
Contlist.Cells(sat, 1) = Contlist.Cells(sat, 2)
Contlist.Cells(WorksheetFunction.Match(Contlist.Cells(sat, 3), [C:C], 0), 1) = Contlist.Cells(sat, 2)

End If

Next

End Sub
 
Ama altaki gibi bir sorunum var ayni numarada yazili 2 adet "CNT" var birincisi dogru sekilde yaziyor ama ikincisinede kapali yazmasini istiyorum yardimlariniz rica ediyorum.

kapali - CNT . 179
- - - - - CNT . 179
kapali - kapali 179
 
Tekrar merhaba.

Verdiğim makroyu başka sayfada çalıştırma ile ilgili meseleyi halletmişsiniz.

Son mesajınızla ilgili olarak; istediğinizin gerçekleşmediği haliyle belgenizin bir örneğini (makro içerisinde olsun) yükleyin bakayım.
Başka bir sütuna da olması gereken sonuçları yazmanızda yarar var.
.
 
Merhabalar ustat bu kodlar isimi gordu lakin aktif oldugu sayfada calisiyor, onun icin ben rapor sayfasinda iken bu makronun sadece "contlist" adina sayfada calismasini nasil uyarlaya biliriz.
simdiden yardimlariniz icin tesekkurler.

Sub kod_deneme()
a = Range("A2:C" & Cells(Rows.Count, 7).End(3).Row)
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
If a(i, 2) <> "CNT" Then
d(a(i, 3)) = i
End If
Next i
ReDim b(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
b(i, 1) = a(d(a(i, 3)), 2)
Next i
[A2].Resize(UBound(a)) = b
MsgBox "İşlem tamam....", vbInformation
End Sub
 
Ömer BARAN' Alıntı:
Tekrar merhaba.

Verdiğim makroyu başka sayfada çalıştırma ile ilgili meseleyi halletmişsiniz.

Son mesajınızla ilgili olarak; istediğinizin gerçekleşmediği haliyle belgenizin bir örneğini (makro içerisinde olsun) yükleyin bakayım.
Başka bir sütuna da olması gereken sonuçları yazmanızda yarar var.
.
Genişletmek için tıkla ...
ok simdi ekliyorum
 
10 numaralı cevabınızda sonuca yaklaşmışsınız sadece aşağıda kırmızı renklendirğim kısım eksik kalmış.
.
Kod: 
Contlist.Cells(WorksheetFunction.Match(Contlist.Cells(sat, 3), [B][COLOR="Red"]Contlist.[/COLOR][/B][C:C], 0), 1) = Contlist.Cells(sat, 2)
 
ustat cok sagol, suan calisdi , sakincasi yoksa bir sorum daha olacak

simdiki yaptigimiz makro digerine gore 15 saniye kadar dusunuyor ama assagidaki diger arkadasin yaptigi 2-3 saniye yapiyor neden kaynaklaniyor, ve onuda contlist sayfasina gore uyarlaya bilirmisiniz acaba , ben o redim ve ubound lari bilmiyorum ve anlamadim
 
Ömer BARAN' Alıntı:
10 numaralı cevabınızda sonuca yaklaşmışsınız sadece aşağıda kırmızı renklendirğim kısım eksik kalmış.
.
Kod: 
Contlist.Cells(WorksheetFunction.Match(Contlist.Cells(sat, 3), [B][COLOR="Red"]Contlist.[/COLOR][/B][C:C], 0), 1) = Contlist.Cells(sat, 2)
Genişletmek için tıkla ...

bu yazdiginiz koda sayfayi ekledim ama, yine 2 tane "CNT" yazan kodun digerine yazmiyor assagida dosyayida gonderdim. size zahmet tesekkurler
 
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.
.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst