Soru Çok hücreli filtrelemeyi Liste haline dökme

Reo41 · 25 Ekim 2024

Selamlar arkadaşlar,

Ekli örnek dosyamda ayrıntılı açıklamayı yaptım.

2. sayfada çok hücreli filtrelemem mevcut, bunu 3. sayfada liste halinde, hangi sütun(adresinde) bulunduğunu görmek istiyorum. Detaylı açıklama 3. sayfada.

Dosya boyutu büyük olduğundan, yardımcı yükleme sitesi ile linki ekliyorum

WeTransfer | Send Large Files Fast - Up To 2GB Free

The simple, quick and secure way to send your files around the world without an account. Share your files, photos, and videos today for free.

we.tl

Yardımlarınız bekliyorum.

hasankardas · 25 Ekim 2024

Selamlar,
dener misin, sayfada karışıklık olmasın diye hücre de virgüllü şekilde yaptım.

Kod:

Sub EslesmeleriBulVeListele()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, resultRow As Long
    Dim colNames As String
    
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    
    resultRow = 2
    
    For i = 6 To 1000
        colNames = ""
        For j = 22 To 256
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
                
                colNames = colNames & ws2.Cells(1, j).Address(False, False) & ", "
            End If
        Next j
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value ' B sütunu = 2. sütun
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
    
    MsgBox "İşlem tamamlandı."
End Sub

Ek bilgi olarak büyük tablolar da koşullu biçimlendirme yapmak işlemcinizin yapacağı işlemi arttıracaktır. Koşullu biçimlendirme ve biçimlendirme den kaçınılmalıdır.

Reo41 · 26 Ekim 2024

hasankardas bey cevabınız için teşekkürler.

Öncelikle makroyla çok fazla tecrübem olmadığından yazdığınız kodu nasıl bir şekilde ekleyeceğimi de anlatabilirmisiniz.

Ayrıca uyarınız için de teşekkürler fakat, koşullu biçimlendirme yapmadan istediğimi elde edemiyorum, en azından benim bildiğim kadarıyla. Varsa başka bir alternatif iletebilirmisiniz ayrıca.

Şimdiden teşekkür ederim

hasankardas' Alıntı:

Selamlar,
dener misin, sayfada karışıklık olmasın diye hücre de virgüllü şekilde yaptım.

Kod:

Sub EslesmeleriBulVeListele()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, resultRow As Long
    Dim colNames As String
   
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
   
    resultRow = 2
   
    For i = 6 To 1000
        colNames = ""
        For j = 22 To 256
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
               
                colNames = colNames & ws2.Cells(1, j).Address(False, False) & ", "
            End If
        Next j
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value ' B sütunu = 2. sütun
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
   
    MsgBox "İşlem tamamlandı."
End Sub

Ek bilgi olarak büyük tablolar da koşullu biçimlendirme yapmak işlemcinizin yapacağı işlemi arttıracaktır. Koşullu biçimlendirme ve biçimlendirme den kaçınılmalıdır.

hasankardas · 27 Ekim 2024

İndir Fatih Soru xls

Dosyayı indir Fatih Soru xls

dosya.co

düzenledim

Reo41 · 29 Ekim 2024

hasankardas' Alıntı:
İndir Fatih Soru xls

Dosyayı indir Fatih Soru xls

dosya.co

düzenledim

Hasankardas bey teşekkürler, bazı uygunsuzluklar mevcut,

* 302. satır ve sonrası takılı sabit kalmış sanırım.
* Olmayan hücreleri var olarak gösteriyor fazladan. Yani filtrelediğim değer mevcut satırda sadece bir hücrede var fakat 2 hücrede veya daha fazla var gösteriyor.
* Hücre isimlerinin bazılarının yanına "1" ekliyor, bazıları da sadece hücre ismi olarak geliyor. Örn; "DU1", "DX"

İndir Fatih Soru (1) xls

Dosyayı indir Fatih Soru (1) xls

dosya.co

hasankardas · 29 Ekim 2024

Sayın reo41 sizin eklediğiniz ile benim eklediğim aynı sonuçları vermiyor. tabloyu inceleme şansım yok fakat düzenleyip tekrar ekledim. evet1 ekliyordu sütun adına aslında çokta önemli değil ama düzenledim artık gelmiyor. Gelenler hücre ismi değil sütun ismi sizin ilk mesajda öyle yazıyor.

İndir Fatih Soru xls

Dosyayı indir Fatih Soru xls

dosya.co

Reo41 · 1 Kasım 2024

hasankardas' Alıntı:
Sayın reo41 sizin eklediğiniz ile benim eklediğim aynı sonuçları vermiyor. tabloyu inceleme şansım yok fakat düzenleyip tekrar ekledim. evet1 ekliyordu sütun adına aslında çokta önemli değil ama düzenledim artık gelmiyor. Gelenler hücre ismi değil sütun ismi sizin ilk mesajda öyle yazıyor.

Hasankardas bey emeğiniz için teşekkür ederim fakat, neden olduğunu ben de anlamadım aynı sıkıntı devam ediyor. Fikir olması açısından ekran görüntüsü ekliyorum. Belli bir satırdan sonrasında takılı kalmış gibi aynı hücreleri hep gösteriyor. Bu kısımları kontrol ettiğimde filtrelediğim değer yerine 0 (sıfır) olan değerleri, filtrelediğim değermiş gibi gösteriyor.

Açıkçası ben de anlam veremedim. Bilginize.

hasankardas · 1 Kasım 2024

Evde ve ofiste farklı excel sürümleri var denedim ikisinde de çalışıyor, şimdi denedim örneğin 2 rakamını denedim.301 satır veri getirdi. şahsımca sizin excel sürümünüz ile ilgili bir sıkıntı olabilir. yeniden yükleme veya onar ma yapar mısınız. Bir ekleme yaptım sheet3 deki verileri önce temizleyip sonra arama yapıyor..

Kod:

Sub getir()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, resultRow As Long
    Dim colNames As String
    
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    ws3.Range("B:F").ClearContents
    
    resultRow = 2
    For i = 6 To 1000
        colNames = ""
        For j = 22 To 256
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
                colNames = colNames & Replace(ws2.Cells(1, j).Address(False, False), "1", "") & ", "
            End If
        Next j
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
    
    MsgBox "İşlem tamamlandı."
End Sub

Reo41 · 1 Kasım 2024

Hasankardas bey bu sefer tamam, hiçbir sıkıntı yok. Çok kez uğraştırdım sizi, elinize emeğinize sağlık. Teşekkür ederim. Elleriniz dert görmesin. Hakkınızı helal edin. Allah razı olsun.
Saygılar

hasankardas · 2 Kasım 2024

Reo41' Alıntı:
Hasankardas bey bu sefer tamam, hiçbir sıkıntı yok. Çok kez uğraştırdım sizi, elinize emeğinize sağlık. Teşekkür ederim. Elleriniz dert görmesin. Hakkınızı helal edin. Allah razı olsun.
Saygılar

Est. Sorun çözüldüyse ne mutlu. Merak ettiğim bu tablo ile ne yapmak istediniz, Hisselerde ne gibi işinize yarıyor.

Reo41 · 3 Kasım 2024

hasankardas' Alıntı:
Est. Sorun çözüldüyse ne mutlu. Merak ettiğim bu tablo ile ne yapmak istediniz, Hisselerde ne gibi işinize yarıyor.

Detaylı takip için, günlük güncelleniyor.

Reo41 · 3 Kasım 2024

Tekrar merhaba Hasankardas bey, yeni bir ihtiyaç/revize durumu oluştu. Tekrar yardımcı olabilirmisiniz.

- 1. sayfada takip etmem gereken, BA sütunundan itibaren ardışık gelen aynı rakamlar. Örn; filtrelediğim değer "1" olsun, BA ve BC sütünü veya başka bir ardışık sütun. 2 ila 10 defaya kadar ardışık gelme ihtimali var.

- 1. ve 2. sayfada Bu sütünların ikinci satırına 1-2-3... diye numara verdim. Sizin hazırladığınız 3. sayfada hücre ismi değil de bu rakamları görme şansımız varmı? Örn; "AO, BE" diye değil de, "3, 7, 9.." vs diye.

- Burda asıl amaç ardışık olanları kontrol etmem, sütun isminden ziyade rakam olarak daha kolay olacak. İlkinde bu şekilde istedim kusura bakmayın ama, kontrol edince, bu şekilde ardışık sütun takibi yapma zorluğunu ortadan kaldırıp, rakamla daha kolay olacağın düşünüyorum.

- Ayrıca ardışık olan sütunları sadece 2. sayfada renklendirmek veya başka türlü belirgin hale getirebilirmiyiz. (2. sayfada 2. satırlara yazdığım numara olan hücreleri) belirgin hale getirmek.

- Artı ve son olarak 3. sayfada 1. satır boş ve filtreleme eklemek istedim, oldu fakat her "GETİR" işlemini yaptıktan sonra filtreleme kalkıyor. Sabitleyebilirmiyiz.

Şimdiden teşekkür ederim.

İndir Fatih soru xlsm

Dosyayı indir Fatih soru xlsm

dosya.co

hasankardas · 3 Kasım 2024

Merhaba,
Size yardımcı oldum fakat siz sorumu geçiştirdiniz. Son kez yardımcı oluyorum.
Sorunuz da 1 ci sorunuzu düzenledim, 2 ci sayfada bir ardışıklık olmadığı için işlem yapmadım. diğer sorunuza da işlem yapmadım çünkü numaralandırma öncesinde de veriler var..

İndir Fatih soru xlsm

Dosyayı indir Fatih soru xlsm

dosya.co

Reo41 · 3 Kasım 2024

hasankardas' Alıntı:
Merhaba,
Size yardımcı oldum fakat siz sorumu geçiştirdiniz. Son kez yardımcı oluyorum.
Sorunuz da 1 ci sorunuzu düzenledim, 2 ci sayfada bir ardışıklık olmadığı için işlem yapmadım. diğer sorunuza da işlem yapmadım çünkü numaralandırma öncesinde de veriler var..

Estağfurullah, geçiştirmek gibi birşey düşünmedim. Bildiğim kadarıyla en net ve kısa cevabı verdim, çünkü ben borsadan hiç anlamam. Çok yakın bir arkadaşıma yardımcı olmaya çalışıyorum. O borsayla ilgileniyor detaylı olarak, gerçekten hiç de merak etmediğim için sormadım. Ama ayrıntılı olarak sormak istediğiniz birşey varsa, bana açıklayıcı sorarsanız ben de ona sorup size cevabını memnuniyetle yazarım.
Yanlış veya eksik bir ifade kullandıysam özür dilerim.

Reo41 · 5 Kasım 2024

Varmı yardımcı olabilecek

pitchoute · 6 Kasım 2024

Merhaba, dener misiniz;

Kod:

Sub getir()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, resultRow As Long
    Dim colNames As String
    Dim isPreviousMatch As Boolean
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    ws3.Range("B2:F1000").ClearContents
    ws2.Range(ws2.Cells(2, 22), ws2.Cells(2, 256)).Interior.ColorIndex = xlNone
    resultRow = 2
    For i = 6 To 1000
        colNames = ""
        isPreviousMatch = False
        For j = 22 To 256
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
                colNames = colNames & ws2.Cells(2, j).Value & ", "
                ws2.Cells(2, j).Interior.Color = RGB(255, 255, 0)
                If isPreviousMatch Then
                    ws2.Cells(2, j).Interior.Color = RGB(0, 255, 0)
                    ws2.Cells(2, j - 1).Interior.Color = RGB(0, 255, 0)
                End If
                isPreviousMatch = True
            Else
                isPreviousMatch = False
            End If
        Next j
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
    MsgBox "İşlem tamamlandı."
End Sub

Reo41 · 6 Kasım 2024

pitchoute' Alıntı:

Merhaba, dener misiniz;

Kod:

Sub getir()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, resultRow As Long
    Dim colNames As String
    Dim isPreviousMatch As Boolean
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    ws3.Range("B2:F1000").ClearContents
    ws2.Range(ws2.Cells(2, 22), ws2.Cells(2, 256)).Interior.ColorIndex = xlNone
    resultRow = 2
    For i = 6 To 1000
        colNames = ""
        isPreviousMatch = False
        For j = 22 To 256
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
                colNames = colNames & ws2.Cells(2, j).Value & ", "
                ws2.Cells(2, j).Interior.Color = RGB(255, 255, 0)
                If isPreviousMatch Then
                    ws2.Cells(2, j).Interior.Color = RGB(0, 255, 0)
                    ws2.Cells(2, j - 1).Interior.Color = RGB(0, 255, 0)
                End If
                isPreviousMatch = True
            Else
                isPreviousMatch = False
            End If
        Next j
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
    MsgBox "İşlem tamamlandı."
End Sub

pitchoute hocam merhaba, teşekkür ederim. Emeğinize sağlık. Tüm istediklerim olmuş. Sadece bazı sütunlarda ardışık olmasına rağmen kimi yerde çift hücreyi renklendirmiş, kimi yerde tek hücreyi, bunu anlayamadım, aynı sütunda 1 den fazla satırda veya yanındaki sütunlarla ortak ardışıklık olamasından dolayı gibimi?
Elinize emeğinize sağlık

pitchoute · 6 Kasım 2024

Merhaba, şu şekilde dener misiniz;

Kod:

Sub getir()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, k As Long, resultRow As Long
    Dim colNames As String
    Dim isMatch As Boolean
    Dim matchStart As Long, matchEnd As Long
    Dim lastRow As Long, lastCol As Long
    Dim filterRange As Range
    Dim filterOn As Boolean
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    If ws3.AutoFilterMode Then
        filterOn = True
        Set filterRange = ws3.AutoFilter.Range
    Else
        filterOn = False
    End If
    ws3.Range("B2:F1000").ClearContents
    ws2.Range(ws2.Cells(2, 22), ws2.Cells(2, ws2.Columns.Count)).Interior.ColorIndex = xlNone
    resultRow = 2
    lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    lastCol = ws2.Cells(2, ws2.Columns.Count).End(xlToLeft).Column
    For i = 6 To lastRow
        colNames = ""
        isMatch = False
        matchStart = 0
        matchEnd = 0
        For j = 22 To lastCol
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
                If isMatch = False Then
                    matchStart = j
                End If
                isMatch = True
                matchEnd = j
            Else
                If isMatch = True Then
                    If matchEnd - matchStart + 1 >= 2 Then
                        For k = matchStart To matchEnd
                            ws2.Cells(2, k).Interior.Color = RGB(0, 255, 0)
                            colNames = colNames & ws2.Cells(2, k).Value & ", "
                        Next k
                    Else
                        ws2.Cells(2, matchStart).Interior.Color = RGB(255, 255, 0)
                        colNames = colNames & ws2.Cells(2, matchStart).Value & ", "
                    End If
                    isMatch = False
                End If
            End If
        Next j
        If isMatch = True Then
            If matchEnd - matchStart + 1 >= 2 Then
                For k = matchStart To matchEnd
                    ws2.Cells(2, k).Interior.Color = RGB(0, 255, 0)
                    colNames = colNames & ws2.Cells(2, k).Value & ", "
                Next k
            Else
                ws2.Cells(2, matchStart).Interior.Color = RGB(255, 255, 0)
                colNames = colNames & ws2.Cells(2, matchStart).Value & ", "
            End If
            isMatch = False
        End If
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
    If filterOn Then
        ws3.Range(filterRange.Address).AutoFilter
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "İşlem tamamlandı."
End Sub

Deneyin, herhangi bir eksiklik ya da hata durumunda paylaşın düzenleme yapmaya çalışayım

Reo41 · 7 Kasım 2024

Durum aynı sayın pitchoute.

Artı olarak Sheet2 de BA'dan önceki filtrelenen değerlerin çıkmaması mümkün mü? Sadece BA ve sonrasını Sheet 3'de görmek istiyorum(yani "0"lar çıkmasın)

Teşekkürler

pitchoute · 7 Kasım 2024

Tekrardan merhaba, şu şekilde dener misiniz;

Kod:

Sub getir()
    Dim ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long, k As Long, resultRow As Long
    Dim colNames As String
    Dim isMatch As Boolean
    Dim matchStart As Long, matchEnd As Long
    Dim lastRow As Long, lastCol As Long
    Dim filterRange As Range
    Dim filterOn As Boolean
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    If ws3.AutoFilterMode Then
        filterOn = True
        Set filterRange = ws3.AutoFilter.Range
    Else
        filterOn = False
    End If
    ws3.Range("B2:F1000").ClearContents
    ws2.Range(ws2.Cells(2, 53), ws2.Cells(2, ws2.Columns.Count)).Interior.ColorIndex = xlNone
    resultRow = 2
    lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    lastCol = ws2.Cells(2, ws2.Columns.Count).End(xlToLeft).Column
    For i = 6 To lastRow
        colNames = ""
        isMatch = False
        matchStart = 0
        matchEnd = 0
        For j = 53 To lastCol
            If ws2.Cells(i, j).Value = ws2.Range("Z1").Value Then
                If isMatch = False Then
                    matchStart = j
                End If
                isMatch = True
                matchEnd = j
            Else
                If isMatch = True Then
                    If matchEnd - matchStart + 1 >= 2 Then
                        For k = matchStart To matchEnd
                            ws2.Cells(2, k).Interior.Color = RGB(0, 255, 0)
                            colNames = colNames & ws2.Cells(2, k).Value & ", "
                        Next k
                    Else
                        ws2.Cells(2, matchStart).Interior.Color = RGB(255, 255, 0)
                        colNames = colNames & ws2.Cells(2, matchStart).Value & ", "
                    End If
                    isMatch = False
                End If
            End If
        Next j
        If isMatch = True Then
            If matchEnd - matchStart + 1 >= 2 Then
                For k = matchStart To matchEnd
                    ws2.Cells(2, k).Interior.Color = RGB(0, 255, 0)
                    colNames = colNames & ws2.Cells(2, k).Value & ", "
                Next k
            Else
                ws2.Cells(2, matchStart).Interior.Color = RGB(255, 255, 0)
                colNames = colNames & ws2.Cells(2, matchStart).Value & ", "
            End If
            isMatch = False
        End If
        If colNames <> "" Then
            colNames = Left(colNames, Len(colNames) - 2)
            ws3.Cells(resultRow, 2).Value = ws2.Cells(i, 2).Value
            ws3.Cells(resultRow, 3).Value = colNames
            resultRow = resultRow + 1
        End If
    Next i
    If filterOn Then
        ws3.Range(filterRange.Address).AutoFilter
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "İşlem tamamlandı."
End Sub

Soru Çok hücreli filtrelemeyi Liste haline dökme

Ekli dosyalar