Arama ve Listeleme Bölümü Yapma Hk.

E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
Merhabalar,

Bir süredir yapısı itibariyle geniş ve satır sayısı yüksek bir excel raporu fonksiyonel hale getirme gayretindeyim. Ancak bir yol alamadım. Örneğini eklediğim raporda da görüldüğü üzere farklı kısaltmalar tablonun birçok yerinde birbirinden farklı tanımlarla mevcut. Yapmak istediğim Aranacak Kısaltma bölümüne yazdığım kısaltmanın detaylarının alttaki tabloda listelenmesi üzerinedir. Bu noktada destek olabilecek biri olursa çok mutlu olurum.

Saygılarımla,
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:R" & eski).ClearContents
sat = 6
For i = 3 To son
    If Cells(i, "C") = [N2] Then
        yeni = Cells(Rows.Count, "N").End(3).Row + 1
        Range("C" & i & ":G" & i).Copy Cells(yeni, "N")
    End If
    If Cells(i, "H") = [N2] Then
        yeni = Cells(Rows.Count, "N").End(3).Row + 1
        Range("H" & i & ":L" & i).Copy Cells(yeni, "N")
    End If
Next
End Sub
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:R" & eski).ClearContents
sat = 6
For i = 3 To son
    If Cells(i, "C") = [N2] Then
        yeni = Cells(Rows.Count, "N").End(3).Row + 1
        Range("C" & i & ":G" & i).Copy Cells(yeni, "N")
    End If
    If Cells(i, "H") = [N2] Then
        yeni = Cells(Rows.Count, "N").End(3).Row + 1
        Range("H" & i & ":L" & i).Copy Cells(yeni, "N")
    End If
Next
End Sub
Genişletmek için tıkla ...
Emeğinize sağlık çok teşekkür ederim.
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
Erdogan3434' Alıntı:
Emeğinize sağlık çok teşekkür ederim.
Genişletmek için tıkla ...
Hocam özür dileyerek atladığım son bir soruyu eklemek isterim. Verilerin yanlarına ilgili aralığın tarihinide getirme imkanınız var mıdır?
Teşekkürler.
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:S" & eski).ClearContents
For i = 1 To son
    If IsDate(Cells(i, "C")) Then
        For j = i + 1 To son
            If Not IsDate(Cells(j, "C")) Then
                If Cells(j, "C") = [N2] Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                End If
            Else
                i = j - 1
                j = son
            End If
        Next
    End If
Next
For i = 1 To son
    If IsDate(Cells(i, "H")) Then
        For j = i + 1 To son
            If Not IsDate(Cells(j, "H")) Then
                If Cells(j, "H") = [N2] Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                End If
            Else
                i = j - 1
                j = son
            End If
        Next
    End If
Next
End Sub
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:S" & eski).ClearContents
For i = 1 To son
    If IsDate(Cells(i, "C")) Then
        For j = i + 1 To son
            If Not IsDate(Cells(j, "C")) Then
                If Cells(j, "C") = [N2] Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                End If
            Else
                i = j - 1
                j = son
            End If
        Next
    End If
Next
For i = 1 To son
    If IsDate(Cells(i, "H")) Then
        For j = i + 1 To son
            If Not IsDate(Cells(j, "H")) Then
                If Cells(j, "H") = [N2] Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                End If
            Else
                i = j - 1
                j = son
            End If
        Next
    End If
Next
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim. Harikasınız.
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
Erdogan3434' Alıntı:
Çok teşekkür ederim. Harikasınız.
Genişletmek için tıkla ...
Hocam sizi çok meşgul ettiğim için öncelikle özür diliyorum. Kodun son hali muhteşem gerçekten. Sadece birşey daha danışmak istiyorum. Örneğin arama kısmını boş bırakarak sorguyu çalıştırsak tüm listenin gelmesi mümkün olur mu? Yardımcı olmak istemezseniz anlarım ama olursanız da cidden çok sevinirim.
Saygılarımla,
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:S" & eski).Clear
If [N2] = "" Then
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Cells(j, "C") <> "" And IsNumeric(Cells(j, "E")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Cells(j, "H") <> "" And IsNumeric(Cells(j, "J")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
Else
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "C")) Then
                    If Cells(j, "C") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "C")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "H")) Then
                    If Cells(j, "H") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "H")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
End If
Range("S6:S" & yeni).NumberFormat = "dd.mm.yyyy"
Range("N:S").EntireColumn.AutoFit
Range("N6:S" & yeni).Borders.LineStyle = 1
End Sub
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:S" & eski).Clear
If [N2] = "" Then
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Cells(j, "C") <> "" And IsNumeric(Cells(j, "E")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Cells(j, "H") <> "" And IsNumeric(Cells(j, "J")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
Else
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "C")) Then
                    If Cells(j, "C") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "C")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "H")) Then
                    If Cells(j, "H") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "H")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
End If
Range("S6:S" & yeni).NumberFormat = "dd.mm.yyyy"
Range("N:S").EntireColumn.AutoFit
Range("N6:S" & yeni).Borders.LineStyle = 1
End Sub
Genişletmek için tıkla ...
Desteğiniz için çok teşekkür ederim.
Saygılarımla.
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyin:

PHP: 
Sub kodlar()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:S" & eski).Clear
If [N2] = "" Then
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Cells(j, "C") <> "" And IsNumeric(Cells(j, "E")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Cells(j, "H") <> "" And IsNumeric(Cells(j, "J")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
Else
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "C")) Then
                    If Cells(j, "C") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "C")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "H")) Then
                    If Cells(j, "H") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "H")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
End If
Range("S6:S" & yeni).NumberFormat = "dd.mm.yyyy"
Range("N:S").EntireColumn.AutoFit
Range("N6:S" & yeni).Borders.LineStyle = 1
End Sub
Genişletmek için tıkla ...
Hocam size karşı cidden mahçubum. İnanın yazmamak için çok denedim ama cidden yapamadım. Ekte ki örnekte de olduğu gibi A sütunundaki bölge verisini T sütununa yazabilir miyiz ?
Saygılarımla.
 

Ekli dosyalar

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Günaydın. Bundan sonra başka bir şey de eklemek isteyecek misiniz? Eğer eklenecekse en baştan söyleyin ki ona göre yapmaya çalışayım. Her seferinde tüm kodları baştan aşağı kontrol edip değiştirmek gerekiyor çünkü.
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
YUSUF44' Alıntı:
Günaydın. Bundan sonra başka bir şey de eklemek isteyecek misiniz? Eğer eklenecekse en baştan söyleyin ki ona göre yapmaya çalışayım. Her seferinde tüm kodları baştan aşağı kontrol edip değiştirmek gerekiyor çünkü.
Genişletmek için tıkla ...
Hayır hocam bu son başka birşey kesinlikle yok.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Şöyle deneyin:

PHP: 
Private Sub CommandButton1_Click()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:T" & eski).Clear
If [N2] = "" Then
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Cells(j, "C") <> "" And IsNumeric(Cells(j, "E")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                    Cells(yeni, "T") = Cells(j, "A")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Cells(j, "H") <> "" And IsNumeric(Cells(j, "J")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                    Cells(yeni, "T") = Cells(j, "A")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
Else
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "C")) Then
                    If Cells(j, "C") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "C")
                        Cells(yeni, "T") = Cells(j, "A")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "H")) Then
                    If Cells(j, "H") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "H")
                        Cells(yeni, "T") = Cells(j, "A")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
End If
Range("S6:S" & yeni).NumberFormat = "dd.mm.yyyy"
Range("N:T").EntireColumn.AutoFit
Range("N6:T" & yeni).Borders.LineStyle = 1
End Sub
 
E

Erdogan3434

Altın Üye
Katılım
14 Ocak 2022
Mesajlar
78
Excel Vers. ve Dili
Office 2013 Professional, Türkçe
Altın Üyelik Bitiş Tarihi
25-01-2028
YUSUF44' Alıntı:
Şöyle deneyin:

PHP: 
Private Sub CommandButton1_Click()
son = WorksheetFunction.Max(Cells(Rows.Count, "C").End(3).Row, Cells(Rows.Count, "H").End(3).Row)
eski = Cells(Rows.Count, "N").End(3).Row
If eski > 5 Then Range("N6:T" & eski).Clear
If [N2] = "" Then
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Cells(j, "C") <> "" And IsNumeric(Cells(j, "E")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "C")
                    Cells(yeni, "T") = Cells(j, "A")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Cells(j, "H") <> "" And IsNumeric(Cells(j, "J")) Then
                    yeni = Cells(Rows.Count, "N").End(3).Row + 1
                    Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                    Cells(yeni, "S") = Cells(i, "H")
                    Cells(yeni, "T") = Cells(j, "A")
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
Else
    For i = 1 To son
        If IsDate(Cells(i, "C")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "C")) Then
                    If Cells(j, "C") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("C" & j & ":G" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "C")
                        Cells(yeni, "T") = Cells(j, "A")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
    For i = 1 To son
        If IsDate(Cells(i, "H")) Then
            For j = i + 2 To son
                If Not IsDate(Cells(j, "H")) Then
                    If Cells(j, "H") = [N2] Then
                        yeni = Cells(Rows.Count, "N").End(3).Row + 1
                        Range("H" & j & ":L" & j).Copy Cells(yeni, "N")
                        Cells(yeni, "S") = Cells(i, "H")
                        Cells(yeni, "T") = Cells(j, "A")
                    End If
                Else
                    i = j - 1
                    j = son
                End If
            Next
        End If
    Next
End If
Range("S6:S" & yeni).NumberFormat = "dd.mm.yyyy"
Range("N:T").EntireColumn.AutoFit
Range("N6:T" & yeni).Borders.LineStyle = 1
End Sub
Genişletmek için tıkla ...
Size yaratmış olduğum onca zahmete rağmen verdiğiniz destekler için çok teşekkür ederim.
Saygı ve Selamlarımla.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst