Belirlenen Bir Aralığı Silme ve Toplama

ahmed_ummu

ahmed_ummu

Altın Üye
Katılım
28 Mart 2011
Mesajlar
731
Excel Vers. ve Dili
Excel 2010 Professional Plus 64 Bit
Altın Üyelik Bitiş Tarihi
15-10-2026
Merhaba arkadaşlar.

Bir sorum olacak ama İnşallah anlatabilirim.

Örnek resmini eklediğim bir excel sayfam var. D5 den AO5'e kadar günler var. Bu sayfadan, bazı durumlarda belirlenen bir aralıktaki ve belirlenen şarta göre silme yapılacak.
Örnek Textbox1'e başlangıç günü 31, Textbox2'ye bitiş günü 6 Yani silinecek aralık belirlenecek. Bu aralığa göre de D7 den başlayarak, A sütununu baz alarak son dolu satıra kadar, C sütunundaki şarta göre silme yapacak. C sütunundaki veri "OKUL MÜDÜRÜ" veya "MÜDÜR YARDIMCISI" ise silme yapmayacak. diğerlerini silecek.

Silme İşlemi yapıldıktan sonra AP sütununa son dolu satıra kadar D5 ve AO5 aralığını toplayacak. Yatay olarak
Sonra da AP7 den başlayarak Son son dolu satırın bir alt satırına dikey olarak toplamları alacak. İnşallah anlatabilmişimdir. Yardımcı olursanız çok sevinirim.
 

Ekli dosyalar

A

AdemCan

Altın Üye
Destek Ekibi
Katılım
1 Eylül 2008
Mesajlar
1,386
Excel Vers. ve Dili
2019 TR
Merhaba, dosya resim olduğu için yardımcı olmak zor. Örnek Excel paylaşır mısınız?
 
A

AdemCan

Altın Üye
Destek Ekibi
Katılım
1 Eylül 2008
Mesajlar
1,386
Excel Vers. ve Dili
2019 TR
Merhaba,
Bu kodları dener misiniz?
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, baslangic As Integer, bitis As Integer, i As Long
Set s1 = Sheets("tablo")
son = s1.Cells(Rows.Count, 2).End(3).Row
baslangic = s1.Range("D5:AO5").Find(s1.Range("AT4")).Column
bitis = s1.Range("D5:AO5").Find(s1.Range("AU4")).Column

s1.Range(s1.Cells(7, baslangic), s1.Cells(son, bitis)).ClearContents

For i = 7 To son
    If s1.Cells(i, "C").Value <> "OKUL MÜDÜRÜ" And s1.Cells(i, 3).Value <> "MÜDÜR YARDIMCISI" Then
        baslangic = s1.Cells(i, "C").Row
        s1.Rows(baslangic & ":" & son).EntireRow.Delete
        Exit For
    End If
Next i

son = s1.Cells(Rows.Count, 2).End(3).Row
For i = 7 To son
    s1.Cells(i, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(i, "D"), s1.Cells(i, "AO")))
Next i

s1.Cells(son + 1, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(7, "AP"), s1.Cells(son, "AP")))

Set s1 = Nothing: son = 0: baslangic = 0: bitis = 0: i = 0
Application.ScreenUpdating = True
End Sub
 
ahmed_ummu

ahmed_ummu

Altın Üye
Katılım
28 Mart 2011
Mesajlar
731
Excel Vers. ve Dili
Excel 2010 Professional Plus 64 Bit
Altın Üyelik Bitiş Tarihi
15-10-2026
faye_efsane' Alıntı:
Merhaba,
Bu kodları dener misiniz?
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, baslangic As Integer, bitis As Integer, i As Long
Set s1 = Sheets("tablo")
son = s1.Cells(Rows.Count, 2).End(3).Row
baslangic = s1.Range("D5:AO5").Find(s1.Range("AT4")).Column
bitis = s1.Range("D5:AO5").Find(s1.Range("AU4")).Column

s1.Range(s1.Cells(7, baslangic), s1.Cells(son, bitis)).ClearContents

For i = 7 To son
    If s1.Cells(i, "C").Value <> "OKUL MÜDÜRÜ" And s1.Cells(i, 3).Value <> "MÜDÜR YARDIMCISI" Then
        baslangic = s1.Cells(i, "C").Row
        s1.Rows(baslangic & ":" & son).EntireRow.Delete
        Exit For
    End If
Next i

son = s1.Cells(Rows.Count, 2).End(3).Row
For i = 7 To son
    s1.Cells(i, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(i, "D"), s1.Cells(i, "AO")))
Next i

s1.Cells(son + 1, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(7, "AP"), s1.Cells(son, "AP")))

Set s1 = Nothing: son = 0: baslangic = 0: bitis = 0: i = 0
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Merhaba
Teşekkürler, İşyerindeki bilgisayarda idi dosyam ancak şimdi bakabildim, deneyeceğim.
 
ahmed_ummu

ahmed_ummu

Altın Üye
Katılım
28 Mart 2011
Mesajlar
731
Excel Vers. ve Dili
Excel 2010 Professional Plus 64 Bit
Altın Üyelik Bitiş Tarihi
15-10-2026
faye_efsane' Alıntı:
Merhaba,
Bu kodları dener misiniz?
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, baslangic As Integer, bitis As Integer, i As Long
Set s1 = Sheets("tablo")
son = s1.Cells(Rows.Count, 2).End(3).Row
baslangic = s1.Range("D5:AO5").Find(s1.Range("AT4")).Column
bitis = s1.Range("D5:AO5").Find(s1.Range("AU4")).Column

s1.Range(s1.Cells(7, baslangic), s1.Cells(son, bitis)).ClearContents

For i = 7 To son
    If s1.Cells(i, "C").Value <> "OKUL MÜDÜRÜ" And s1.Cells(i, 3).Value <> "MÜDÜR YARDIMCISI" Then
        baslangic = s1.Cells(i, "C").Row
        s1.Rows(baslangic & ":" & son).EntireRow.Delete
        Exit For
    End If
Next i

son = s1.Cells(Rows.Count, 2).End(3).Row
For i = 7 To son
    s1.Cells(i, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(i, "D"), s1.Cells(i, "AO")))
Next i

s1.Cells(son + 1, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(7, "AP"), s1.Cells(son, "AP")))

Set s1 = Nothing: son = 0: baslangic = 0: bitis = 0: i = 0
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Sayın faye_afsane öncelikle teşekkür ederim ilginize. Resmini gönderdiğim sonuç çıktı. AT4 ve AU4 hücrelerine girdiğim değerlere göre gönderdiğim ilk örnek resim deki sarı alanların silinmesi gerekiyor. Satır değil sadece rakamlar.
Denediğim kodda ise C sütunundaki değer OKUL MÜDÜRÜ ve MÜDÜR YARDIMCISI değilise tüm satır siliniyor. Sadece belirtilen aralıktaki rakamlar silinecek.

Bu hali ile yaptığı işlemi C sütununun değeri OKUL MÜDRÜ ve MÜDÜR YARDIMCISI olmayan kişilere yapacak.
 

Ekli dosyalar

A

AdemCan

Altın Üye
Destek Ekibi
Katılım
1 Eylül 2008
Mesajlar
1,386
Excel Vers. ve Dili
2019 TR
Merhaba, " ... belirlenen bir aralıktaki ve belirlenen şarta göre silme yapılacak." konusunu yanlış anlamışım kusura bakmayın.
Satır silme kodlarını çıkarttım, belirlenen aralıktaki hücre içeriğini temizleyen ve işlem sonunda toplam alan kodlar.
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, baslangic As Integer, bitis As Integer, i As Long
Set s1 = Sheets("tablo")
son = s1.Cells(Rows.Count, 2).End(3).Row
baslangic = s1.Range("D5:AO5").Find(s1.Range("AT4")).Column
bitis = s1.Range("D5:AO5").Find(s1.Range("AU4")).Column

For i = 7 To son
    If s1.Cells(i, "C").Value <> "OKUL MÜDÜRÜ" And s1.Cells(i, 3).Value <> "MÜDÜR YARDIMCISI" Then
        s1.Range(s1.Cells(i, baslangic), s1.Cells(i, bitis)).ClearContents
    End If
Next i

For i = 7 To son
    s1.Cells(i, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(i, "D"), s1.Cells(i, "AO")))
Next i

s1.Cells(son + 1, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(7, "AP"), s1.Cells(son, "AP")))

Set s1 = Nothing: son = 0: baslangic = 0: bitis = 0: i = 0
Application.ScreenUpdating = True
End Sub
 
ahmed_ummu

ahmed_ummu

Altın Üye
Katılım
28 Mart 2011
Mesajlar
731
Excel Vers. ve Dili
Excel 2010 Professional Plus 64 Bit
Altın Üyelik Bitiş Tarihi
15-10-2026
faye_efsane' Alıntı:
Merhaba, " ... belirlenen bir aralıktaki ve belirlenen şarta göre silme yapılacak." konusunu yanlış anlamışım kusura bakmayın.
Satır silme kodlarını çıkarttım, belirlenen aralıktaki hücre içeriğini temizleyen ve işlem sonunda toplam alan kodlar.
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, baslangic As Integer, bitis As Integer, i As Long
Set s1 = Sheets("tablo")
son = s1.Cells(Rows.Count, 2).End(3).Row
baslangic = s1.Range("D5:AO5").Find(s1.Range("AT4")).Column
bitis = s1.Range("D5:AO5").Find(s1.Range("AU4")).Column

For i = 7 To son
    If s1.Cells(i, "C").Value <> "OKUL MÜDÜRÜ" And s1.Cells(i, 3).Value <> "MÜDÜR YARDIMCISI" Then
        s1.Range(s1.Cells(i, baslangic), s1.Cells(i, bitis)).ClearContents
    End If
Next i

For i = 7 To son
    s1.Cells(i, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(i, "D"), s1.Cells(i, "AO")))
Next i

s1.Cells(son + 1, "AP").Value = WorksheetFunction.Sum(s1.Range(s1.Cells(7, "AP"), s1.Cells(son, "AP")))

Set s1 = Nothing: son = 0: baslangic = 0: bitis = 0: i = 0
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Çok teşekkürler sayın faye_afsane çok güzel olmuş, elinize sağlık.
 
A

AdemCan

Altın Üye
Destek Ekibi
Katılım
1 Eylül 2008
Mesajlar
1,386
Excel Vers. ve Dili
2019 TR
Rica ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst