• DİKKAT

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

birden çok sütunda metin parçalarına göre süzme makro

  • Konbuyu başlatan Konbuyu başlatan modoste
  • Başlangıç tarihi Başlangıç tarihi

modoste

Altın Üye
Katılım
31 Mayıs 2008
Mesajlar
3,712
Excel Vers. ve Dili
Microsoft OFFİCE Ev ve İş 2019 TR
merhaba sayın hocalarım
ekli dosyamda bir sütundaki metin parçasına göre listenin süzülmesi ile ilgili formülle çözüm bulunuyor
benim istediğim ise tablonun sağındada açıklamasını yaptığım
birden çok sütundaki metin parçaları kriterlerine göre makro ile süzme sıralama yapılması.
 

Ekli dosyalar

Merhaba.

-- J3 ve K3 hücrelerinin biçimini METİN olarak ayarlayın,
-- J:M sütun aralığındaki formülleri silin,
-- alt taraftan ilgili sayfa adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- açılan VBA ekranında sağ taraftaki boş alana aşağıdaki kod'u yapıştırın

-- Hem J3 boş, hem K3 boş iken J:M sütun aralığındaki listenin boş olmamasını istiyorsanız, kırmızı renklendirdiğim satırı silin.
.
Kod:
[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Intersect(Target, [J3, K3]) Is Nothing Then Exit Sub
If Cells(Rows.Count, "J").End(3).Row > 5 Then Range("J6:M" & Cells(Rows.Count, "J").End(3).Row).ClearContents
[COLOR="Red"]If [J3] = "" And [K3] = "" Then Exit Sub[/COLOR]
If [J3] <> "" Then Range("C5:F" & Cells(Rows.Count, 3).End(3).Row).AutoFilter Field:=1, Criteria1:="*" & [J3].Text & "*"
If [K3] <> "" Then Range("C5:F" & Cells(Rows.Count, 3).End(3).Row).AutoFilter Field:=2, Criteria1:="*" & [K3].Text & "*"
If Cells(Rows.Count, 3).End(3).Row = 5 Then GoTo 10
Range("C6:F" & Cells(Rows.Count, 3).End(3).Row).SpecialCells(xlCellTypeVisible).Copy [J6]
10: Range("C5:F" & Cells(Rows.Count, 3).End(3).Row).AutoFilter
[B]End Sub[/B]
 
teşekkür ederim sayın ömer baran
kullanmaya başladım makrolu çizelgeyi
 
sayın Ömer.Baran hocam bu istediğim çözümden daha başka yani daha fazla sütunların kullanılacağı çizelgelerde ileride karşıma çıkıcam buna dönük bir çalışma yapabilirmisiniz

örneğin veriler B-C-D-E-F-G-H-I-İ-J diyelim yani 10 sütun için aynı mantıkta makro yapabilir misiniz.
 
eklediğim dosyada verilen listeye göre belirlediğim kriterlere göre makro ile süzme yapabilirmiyiz.
 
makro ile süzme

yeni bir dosya ile soru
 

Ekli dosyalar

sayın hocalarımdan makro ile çözüm gelene kadar formülle çözüm üretmeye çalıştım
faydası olur diye eklemek istedim.
8 sütundaki kriterlere göre kiminde sayısal kiminde metinsel ifadelere göre süzme yapmaya çalıştım
 

Ekli dosyalar

sayın Ömer BARAN Hocam
bu konuyla ilgili yeni bir makro isteğim olacaktı hocam
2 sene boyunca kullandığım tablomda veriler 4 sütundan ibaretti ve ona göre 2 sütundaki metin veya metin parçasına göre makro ile süzme yapmıştınız. şimdi ise veriler 5 sütuna çıktı ve ben bu sefer en fazla 3 sütunda kriter yazarak makro ile sonuç elde etmek istiyorum
ekli dosyamda "ilk makro" dosyasında ilk durum sizin çözümünüzle kullandığım durum
"2. istek makro" dosyasında ise sorumu ilettim. veriler C6:G6 aralığından başlayacak K3,L3 ve M3 sekmesinde ifade yazılacak eğer 3 üne yazılırsa 3 lü süzme eğer birine veri yazılırsa tek süzme gibi makro yapılcak hocam
(makroda ben hücrelere veri yazıp enter dediğimde makro çalışıyordu yine o dönüşümde olmalı)
Not: eski çözümdeki makrodaki, kodu dönüştürmeye çalıştım harfleri kaydırmaya çalıştım ama başaramadım hocam.

ekli dosyalarımın her biri 1,90 mb olduğundan bu şekilde eklemek zorunda kaldım hocam
 

Ekli dosyalar

Umarım yanlış anlamadım.
Alt taraftan YENİ İSTEK saysının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan ekranda sağdaki alana aşağıdaki kod blokunu yapıştırın.
Rich (BB code):
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [K3:M3]) Is Nothing Then Exit Sub
If Cells(Rows.Count, "K").End(3).Row > 5 Then _
    Range("K6:O" & Cells(Rows.Count, "K").End(3).Row).ClearContents
If [K3] = "" And [L3] = "" And [M3] = "" Then Exit Sub
cson = Cells(Rows.Count, 3).End(3).Row
If [K3] <> "" Then Range("C5:G" & cson ).AutoFilter Field:=1, Criteria1:="*" & [K3].Text & "*"
If [L3] <> "" Then Range("C5:G" & cson ).AutoFilter Field:=2, Criteria1:="*" & [L3].Text & "*"
If [M3] <> "" Then Range("C5:G" & cson ).AutoFilter Field:=3, Criteria1:="*" & [M3].Text & "*"
If Cells(Rows.Count, 3).End(3).Row = 5 Then GoTo 10
Range("C6:G" & cson).SpecialCells(xlCellTypeVisible).Copy [K6]
10: Range("C5:G" & cson ).AutoFilter
End Sub
 
uyguladım teşekkür ederim sayın ömer hocam
daha fazla sütun eklenirse modüldeki satır sütun yardımcı olur dimi hocam Kırmızı koyu renkle belirttiklerini değiştirdiğim taktirde yeni sonuçlar elde edilir.
 
Sorun olursa yine yazarsınız, bakarım.
 
Geri
Üst