• DİKKAT

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

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

S

sezgin06

Katılım
26 Eylül 2021
Mesajlar
52
Excel Vers. ve Dili
2016 Türkçe
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?
 

Ekli dosyalar

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
 
@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
 
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
Genişletmek için tıkla ...
Sayın @veyselemre emeğinize sağlık sorunsuz çalıştı çok teşekkür ederim. Kolay gelsin
 
Ö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
Genişletmek için tıkla ...
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?
 
Ş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
 
Ö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
Genişletmek için tıkla ...
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?
 
Kodu bu haliyle kullandıysanız, M7:Q7 aralığında sarı renkli başlıklarınız mevcut mudur?
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
 
Ö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
Genişletmek için tıkla ...
Söylediklerinizi uyguladım ancak yeni veriler girildiğinde hata veriyor eklediğim tabloda her iki makroda yüklü farklı sonuçlar çıktı
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst