Sütunda boş hücre varsa satır silinsin

sezgin06 · 14 Kasım 2021

Merhaba;

M sütununda boş olan hücrelerin dinamik tablodaki satırları, yandaki örnek gibi makroda düzenleme yapılarak silinip veriler yukarıya nasıl taşınabilir?

veyselemre · 14 Kasım 2021

Kod:

Sub analiz()
    Dim son&, veri, liste, i&, ii%, say&, sira&, ky$
    Application.ScreenUpdating = False
    son = Cells(Rows.Count, 2).End(3).Row
    veri = Range("B2:G" & son).Value
    
    ReDim liste(1 To UBound(veri), 1 To 5)
    
    With Range("j2:n" & Rows.Count)
        .ClearContents
        .Borders.LineStyle = xlNone
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 2) & "|" & veri(i, 6)
            If Not .exists(ky) Then
                say = say + 1
                .Item(ky) = say
                liste(say, 1) = veri(i, 2)
                liste(say, 5) = veri(i, 6)
            End If
            sira = .Item(ky)
            If veri(i, 1) = "Alış" Then
                liste(sira, 2) = liste(sira, 2) + veri(i, 4)
            Else
                liste(sira, 3) = liste(sira, 3) + veri(i, 4)
            End If
        Next i
    End With
    
    sira = 1
    For i = 1 To say
        If liste(i, 2) - liste(i, 3) > 0 Then
            sira = sira + 1
            liste(i, 4) = liste(i, 2) - liste(i, 3)
            For ii = 1 To 5
                Cells(sira, ii + 9).Value = liste(i, ii)
            Next ii
        End If
    Next i
    
    With Range("J1:N" & sira)
        .Sort Range("J1"), xlAscending, , Range("N1"), xlAscending, , , xlYes
        .Borders.LineStyle = xlContinuous
    End With
    Application.ScreenUpdating = True
    MsgBox "İşlem TAMAM.", vbInformation

End Sub

ÖmerFaruk · 14 Kasım 2021

@veyselemre bey cevaplamış.
Ben yine de benzer şekilde yaptığımı paylaşayım. Kodlar zenginleşsin.
Module içine yapıştırıp butona atayabilirsiniz.

C++:

Sub Yeni()
Dim Say As Integer, Yaz As Integer, i As Integer, Veri, Liste, xListe, Sayfa As Worksheet
    Set Sayfa = Worksheets("Sayfa1")
    With Sayfa
        .Range("J2:N" & Rows.Count).Clear
        Veri = .Range("B2:G" & .Range("B" & Rows.Count).End(3).Row).Value
        With VBA.CreateObject("Scripting.Dictionary")
            ReDim Liste(1 To 5, 1 To 1)
            For i = LBound(Veri) To UBound(Veri)
                If Not .Exists(Veri(i, 2) & "-" & Veri(i, 6)) Then
                    Say = Say + 1
                    ReDim Preserve Liste(1 To 5, 1 To Say)
                    .Add Veri(i, 2) & "-" & Veri(i, 6), Say
                    Liste(1, Say) = Veri(i, 2)
                    If Left(Veri(i, 1), 1) = "A" Then Liste(2, Say) = Veri(i, 4) Else Liste(3, Say) = Veri(i, 4)
                    Liste(5, Say) = Veri(i, 6)
                Else
                    xNo = .Item(Veri(i, 2) & "-" & Veri(i, 6))
                    If Left(Veri(i, 1), 1) = "A" Then
                        Liste(2, xNo) = Veri(i, 4) + Liste(2, xNo)
                    Else
                        Liste(3, xNo) = Veri(i, 4) + Liste(3, xNo)
                    End If
                    Liste(4, xNo) = Liste(2, xNo) - Liste(3, xNo)
            
                End If
            Next i
        End With
        ReDim xListe(1 To 5, 1 To 1)
        For i = 1 To Say
            If Liste(4, i) * 1 > 0 Then
                Yaz = Yaz + 1
                ReDim Preserve xListe(1 To 5, 1 To Yaz)
                xListe(1, Yaz) = Liste(1, i)
                xListe(2, Yaz) = Liste(2, i)
                xListe(3, Yaz) = Liste(3, i)
                xListe(4, Yaz) = Liste(4, i)
                xListe(5, Yaz) = Liste(5, i)
            End If
        Next i
        .Range("J2").Resize(Yaz, 5) = Application.Transpose(xListe)
        .Range("J2").Resize(Yaz, 5).Sort Key1:=.Range("J1"), Order1:=xlAscending, Key2:=.Range("N1"), Order2:=xlAscending
        .Range("J1").Resize(Yaz + 1, 5).Borders.LineStyle = xlContinuous
        .Range("J:J").HorizontalAlignment = xlHAlignLeft
        .Range("N:N").HorizontalAlignment = xlHAlignLeft
        .Range("J:J").IndentLevel = 1
        .Range("N:N").IndentLevel = 1
    End With
    Set Sayfa = Nothing
End Sub

sezgin06 · 14 Kasım 2021

veyselemre' Alıntı:

Kod:

Sub analiz()
    Dim son&, veri, liste, i&, ii%, say&, sira&, ky$
    Application.ScreenUpdating = False
    son = Cells(Rows.Count, 2).End(3).Row
    veri = Range("B2:G" & son).Value
   
    ReDim liste(1 To UBound(veri), 1 To 5)
   
    With Range("j2:n" & Rows.Count)
        .ClearContents
        .Borders.LineStyle = xlNone
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 2) & "|" & veri(i, 6)
            If Not .exists(ky) Then
                say = say + 1
                .Item(ky) = say
                liste(say, 1) = veri(i, 2)
                liste(say, 5) = veri(i, 6)
            End If
            sira = .Item(ky)
            If veri(i, 1) = "Alış" Then
                liste(sira, 2) = liste(sira, 2) + veri(i, 4)
            Else
                liste(sira, 3) = liste(sira, 3) + veri(i, 4)
            End If
        Next i
    End With
   
    sira = 1
    For i = 1 To say
        If liste(i, 2) - liste(i, 3) > 0 Then
            sira = sira + 1
            liste(i, 4) = liste(i, 2) - liste(i, 3)
            For ii = 1 To 5
                Cells(sira, ii + 9).Value = liste(i, ii)
            Next ii
        End If
    Next i
   
    With Range("J1:N" & sira)
        .Sort Range("J1"), xlAscending, , Range("N1"), xlAscending, , , xlYes
        .Borders.LineStyle = xlContinuous
    End With
    Application.ScreenUpdating = True
    MsgBox "İşlem TAMAM.", vbInformation

End Sub

Sayın @veyselemre emeğinize sağlık sorunsuz çalıştı çok teşekkür ederim. Kolay gelsin

sezgin06 · 14 Kasım 2021

ÖmerFaruk' Alıntı:

@veyselemre bey cevaplamış.
Ben yine de benzer şekilde yaptığımı paylaşayım. Kodlar zenginleşsin.
Module içine yapıştırıp butona atayabilirsiniz.

C++:

Sub Yeni()
Dim Say As Integer, Yaz As Integer, i As Integer, Veri, Liste, xListe, Sayfa As Worksheet
    Set Sayfa = Worksheets("Sayfa1")
    With Sayfa
        .Range("J2:N" & Rows.Count).Clear
        Veri = .Range("B2:G" & .Range("B" & Rows.Count).End(3).Row).Value
        With VBA.CreateObject("Scripting.Dictionary")
            ReDim Liste(1 To 5, 1 To 1)
            For i = LBound(Veri) To UBound(Veri)
                If Not .Exists(Veri(i, 2) & "-" & Veri(i, 6)) Then
                    Say = Say + 1
                    ReDim Preserve Liste(1 To 5, 1 To Say)
                    .Add Veri(i, 2) & "-" & Veri(i, 6), Say
                    Liste(1, Say) = Veri(i, 2)
                    If Left(Veri(i, 1), 1) = "A" Then Liste(2, Say) = Veri(i, 4) Else Liste(3, Say) = Veri(i, 4)
                    Liste(5, Say) = Veri(i, 6)
                Else
                    xNo = .Item(Veri(i, 2) & "-" & Veri(i, 6))
                    If Left(Veri(i, 1), 1) = "A" Then
                        Liste(2, xNo) = Veri(i, 4) + Liste(2, xNo)
                    Else
                        Liste(3, xNo) = Veri(i, 4) + Liste(3, xNo)
                    End If
                    Liste(4, xNo) = Liste(2, xNo) - Liste(3, xNo)
           
                End If
            Next i
        End With
        ReDim xListe(1 To 5, 1 To 1)
        For i = 1 To Say
            If Liste(4, i) * 1 > 0 Then
                Yaz = Yaz + 1
                ReDim Preserve xListe(1 To 5, 1 To Yaz)
                xListe(1, Yaz) = Liste(1, i)
                xListe(2, Yaz) = Liste(2, i)
                xListe(3, Yaz) = Liste(3, i)
                xListe(4, Yaz) = Liste(4, i)
                xListe(5, Yaz) = Liste(5, i)
            End If
        Next i
        .Range("J2").Resize(Yaz, 5) = Application.Transpose(xListe)
        .Range("J2").Resize(Yaz, 5).Sort Key1:=.Range("J1"), Order1:=xlAscending, Key2:=.Range("N1"), Order2:=xlAscending
        .Range("J1").Resize(Yaz + 1, 5).Borders.LineStyle = xlContinuous
        .Range("J:J").HorizontalAlignment = xlHAlignLeft
        .Range("N:N").HorizontalAlignment = xlHAlignLeft
        .Range("J:J").IndentLevel = 1
        .Range("N:N").IndentLevel = 1
    End With
    Set Sayfa = Nothing
End Sub

Sayın @ÖmerFaruk sizin de ilginize teşekkür ederim...

.Range("J2").Resize(Yaz, 5) = Application.Transpose(xListe)

satırında hata verdi, dediğiniz gibi module atadım acaba benden mi kaynaklanıyor?

sezgin06 · 14 Kasım 2021

sezgin06' Alıntı:
Sayın @ÖmerFaruk sizin de ilginize teşekkür ederim...

.Range("J2").Resize(Yaz, 5) = Application.Transpose(xListe)

satırında hata verdi, dediğiniz gibi module atadım acaba benden mi kaynaklanıyor?

@veyselemre bey in makrosunu ,Tablonun orjinali J1 değil M7 den başlıyor ona göre uyarlamaya çalıştım ancak olmadı.

ÖmerFaruk · 14 Kasım 2021

Şu şekilde deneyin. (Tabloyu da M7 den başlattım ve kodların içinde gerekiyorsa yerini değiştirebilesiniz diye açıklama yaptım)

C++:

Sub Yeni()
Dim Say As Integer, Yaz As Integer, i As Integer, Veri, Liste, Sayfa As Worksheet, tabloilkhücre As Range
    Set Sayfa = Worksheets("Sayfa1")
    With Sayfa
        .Range("J2:N" & Rows.Count).Clear
        Veri = .Range("B2:G" & .Range("B" & Rows.Count).End(3).Row).Value
        With VBA.CreateObject("Scripting.Dictionary")
            ReDim Liste(1 To 5, 1 To 1)
            For i = LBound(Veri) To UBound(Veri)
                If Not .Exists(Veri(i, 2) & "-" & Veri(i, 6)) Then
                    Say = Say + 1
                    ReDim Preserve Liste(1 To 5, 1 To Say)
                    .Add Veri(i, 2) & "-" & Veri(i, 6), Say
                    Liste(1, Say) = Veri(i, 2)
                    If Left(Veri(i, 1), 1) = "A" Then Liste(2, Say) = Veri(i, 4) Else Liste(3, Say) = Veri(i, 4)
                    Liste(5, Say) = Veri(i, 6)
                Else
                    xNo = .Item(Veri(i, 2) & "-" & Veri(i, 6))
                    If Left(Veri(i, 1), 1) = "A" Then
                        Liste(2, xNo) = Veri(i, 4) + Liste(2, xNo)
                    Else
                        Liste(3, xNo) = Veri(i, 4) + Liste(3, xNo)
                    End If
                    Liste(4, xNo) = Liste(2, xNo) - Liste(3, xNo)
           
                End If
            Next i
        End With
        Set tabloilkhücre = .Range("M7") 'Tablonuzun sol üst hücre adresini buradan deðiþtiebilirsin
        For i = 1 To Say
            If Liste(4, i) * 1 > 0 Then
                Yaz = Yaz + 1
                tabloilkhücre.Offset(Yaz, 0) = Liste(1, i)
                tabloilkhücre.Offset(Yaz, 1) = Liste(2, i)
                tabloilkhücre.Offset(Yaz, 2) = Liste(3, i)
                tabloilkhücre.Offset(Yaz, 3) = Liste(4, i)
                tabloilkhücre.Offset(Yaz, 4) = Liste(5, i)
            End If
        Next i
        tabloilkhücre.Offset(1, 0).Resize(Yaz, 5).Sort Key1:=tabloilkhücre.Offset(0, 0), Order1:=xlAscending, Key2:=tabloilkhücre.Offset(0, 4), Order2:=xlAscending
        tabloilkhücre.Offset(0, 0).Resize(Yaz + 1, 5).Borders.LineStyle = xlContinuous
        .Columns(tabloilkhücre.Column).HorizontalAlignment = xlHAlignLeft
        .Columns(tabloilkhücre.Column + 4).HorizontalAlignment = xlHAlignLeft
        .Columns(tabloilkhücre.Column).IndentLevel = 1
        .Columns(tabloilkhücre.Column + 4).IndentLevel = 1
    End With
    Set Sayfa = Nothing: Set tabloilkhücre = Nothing
End Sub

sezgin06 · 14 Kasım 2021

ÖmerFaruk' Alıntı:

Şu şekilde deneyin. (Tabloyu da M7 den başlattım ve kodların içinde gerekiyorsa yerini değiştirebilesiniz diye açıklama yaptım)

C++:

Sub Yeni()
Dim Say As Integer, Yaz As Integer, i As Integer, Veri, Liste, Sayfa As Worksheet, tabloilkhücre As Range
    Set Sayfa = Worksheets("Sayfa1")
    With Sayfa
        .Range("J2:N" & Rows.Count).Clear
        Veri = .Range("B2:G" & .Range("B" & Rows.Count).End(3).Row).Value
        With VBA.CreateObject("Scripting.Dictionary")
            ReDim Liste(1 To 5, 1 To 1)
            For i = LBound(Veri) To UBound(Veri)
                If Not .Exists(Veri(i, 2) & "-" & Veri(i, 6)) Then
                    Say = Say + 1
                    ReDim Preserve Liste(1 To 5, 1 To Say)
                    .Add Veri(i, 2) & "-" & Veri(i, 6), Say
                    Liste(1, Say) = Veri(i, 2)
                    If Left(Veri(i, 1), 1) = "A" Then Liste(2, Say) = Veri(i, 4) Else Liste(3, Say) = Veri(i, 4)
                    Liste(5, Say) = Veri(i, 6)
                Else
                    xNo = .Item(Veri(i, 2) & "-" & Veri(i, 6))
                    If Left(Veri(i, 1), 1) = "A" Then
                        Liste(2, xNo) = Veri(i, 4) + Liste(2, xNo)
                    Else
                        Liste(3, xNo) = Veri(i, 4) + Liste(3, xNo)
                    End If
                    Liste(4, xNo) = Liste(2, xNo) - Liste(3, xNo)
          
                End If
            Next i
        End With
        Set tabloilkhücre = .Range("M7") 'Tablonuzun sol üst hücre adresini buradan deðiþtiebilirsin
        For i = 1 To Say
            If Liste(4, i) * 1 > 0 Then
                Yaz = Yaz + 1
                tabloilkhücre.Offset(Yaz, 0) = Liste(1, i)
                tabloilkhücre.Offset(Yaz, 1) = Liste(2, i)
                tabloilkhücre.Offset(Yaz, 2) = Liste(3, i)
                tabloilkhücre.Offset(Yaz, 3) = Liste(4, i)
                tabloilkhücre.Offset(Yaz, 4) = Liste(5, i)
            End If
        Next i
        tabloilkhücre.Offset(1, 0).Resize(Yaz, 5).Sort Key1:=tabloilkhücre.Offset(0, 0), Order1:=xlAscending, Key2:=tabloilkhücre.Offset(0, 4), Order2:=xlAscending
        tabloilkhücre.Offset(0, 0).Resize(Yaz + 1, 5).Borders.LineStyle = xlContinuous
        .Columns(tabloilkhücre.Column).HorizontalAlignment = xlHAlignLeft
        .Columns(tabloilkhücre.Column + 4).HorizontalAlignment = xlHAlignLeft
        .Columns(tabloilkhücre.Column).IndentLevel = 1
        .Columns(tabloilkhücre.Column + 4).IndentLevel = 1
    End With
    Set Sayfa = Nothing: Set tabloilkhücre = Nothing
End Sub

tabloilkhücre.Offset(1, 0).Resize(Yaz, 5).Sort Key1:=tabloilkhücre.Offset(0, 0), Order1:=xlAscending, Key2:=tabloilkhücre.Offset(0, 4), Order2:=xlAscending

Satırı hata verdi @ÖmerFaruk bey yanlış birşey mi yapıyorum acaba?

ÖmerFaruk · 14 Kasım 2021

Kodu bu haliyle kullandıysanız, M7:Q7 aralığında sarı renkli başlıklarınız mevcut mudur?

Ayrıca kodda
en başlardaki aşağıdaki satırı silin
.Range("J2:N" & Rows.Count).Clear

ve şu satırın altına da altındaki satırı ilave edin
Set tabloilkhücre = .Range("M7") 'Tablonuzun sol üst hücre adresini buradan deðiþtiebilirsin
.Range(tabloilkhücre.Offset(1, 0), Cells(Rows.Count, tabloilkhücre.Column + 4)).Clear

sezgin06 · 14 Kasım 2021

ÖmerFaruk' Alıntı:
Kodu bu haliyle kullandıysanız, M7:Q7 aralığında sarı renkli başlıklarınız mevcut mudur?
Ekli dosyayı görüntüle 231734

Ayrıca kodda
en başlardaki aşağıdaki satırı silin
.Range("J2:N" & Rows.Count).Clear

ve şu satırın altına da altındaki satırı ilave edin
Set tabloilkhücre = .Range("M7") 'Tablonuzun sol üst hücre adresini buradan deðiþtiebilirsin
.Range(tabloilkhücre.Offset(1, 0), Cells(Rows.Count, tabloilkhücre.Column + 4)).Clear

Söylediklerinizi uyguladım ancak yeni veriler girildiğinde hata veriyor eklediğim tabloda her iki makroda yüklü farklı sonuçlar çıktı

ÖmerFaruk · 14 Kasım 2021

Dosyanız ekte.

sezgin06 · 14 Kasım 2021

ÖmerFaruk' Alıntı:
Dosyanız ekte.

Sayın @ÖmerFaruk kıymetli vaktinizi ayırıp ilgilendiğiniz için teşekkür ederim. Emeğinize sağlık sorunsuz çalıştı

Sütunda boş hücre varsa satır silinsin

sezgin06

Ekli dosyalar

veyselemre

Özel Üye

ÖmerFaruk

Destek Ekibi

sezgin06

sezgin06

sezgin06

ÖmerFaruk

Destek Ekibi

sezgin06

ÖmerFaruk

Destek Ekibi

sezgin06

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

Ekli dosyalar

sezgin06