• DİKKAT

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

tek buton ile belirli hücreleri temizleme

vuranoğlu

vuranoğlu

Altın Üye
Katılım
18 Nisan 2008
Mesajlar
260
Excel Vers. ve Dili
excel 2016 tr
İyi akşamlar.

Sub temizle()
For t = 1 To Sheets.Count
Sheets(t).Select
For Each hucre In [F3:G78]

If hucre.Interior.Color = vbYellow Then hucre.ClearContents
Next
Next
'Yellow

'lightGreen
'skyblue

End Sub

Hazırladığım çalışma sayfasında ilgili renkli hücrelerin temizlenmesi yukarıdaki kod ile yapılabiliyor.
Ancak;
Ana renklerin dışındaki (skyblue -lightyreen - light yellow gibi ) renkli hücrelerin silme işlemi için ne yapmak gerekiyor?
 

Ekli dosyalar

Ya araya or ile bağlantı kurabilirsiniz. Ya da hucre.Interior.Color <> xlNone şeklinde renksize eşit değilse şeklinde yazabilirsiniz.
 
hucre.Interior.Color <> xlNone
Bu şekilde tüm satırı siliyor.
 
Kod: 
Sub temizle()
For t = 1 To Sheets.Count
Sheets(t).Select
For Each hucre In [F3:G78]
If hucre.Interior.Color <> 16777215 Then
    hucre.Select 'ilgili hücreye gidiyor
    hucre.ClearContents 'Hücreyi temizliyor 
    hucre.Interior.Color = 16777215 'Hücrenin rengini temizliyor
End If
'If hucre.Interior.Color = vblightGreen Then hucre.ClearContents
Next
Next
'Yellow
'LIGHTGREEN
'lightGreen
'sky blue
End Sub
 
askm
İlgine teşekkürler.
Ancak sütunların hem rengini hem tüm verileri siliyor.
İstenen belirli renkteki hücreleri silmek.Ekteki kod ana renklere göre çalışıyor.
Yapılmak istenen ara renkleri silmek( pembe, açık sarı, açık yeşil ,açık mavi ) gibi bunlarda sorun oluyor.
 
Aşağıdaki kodu deneyiniz.

İkinci kod ile içeriğini silmek istediğiniz hücrenin renk kodunu öğrenebilirsiniz. Öğrendiğiniz kodu makronun içine ekleyebilirsiniz.

Kod: 
Sub Temizle()
    Renkler = Array(14743787, 16777164)
    For Each Sayfa In ThisWorkbook.Worksheets
        For Each Hucre In Sayfa.Range("F3:G78")
            For Y = 0 To UBound(Renkler)
                If Hucre.Interior.Color = Renkler(Y) Then Hucre.ClearContents
            Next
        Next
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sub Renk_Kodu()
    MsgBox ActiveCell.Interior.Color
End Sub
 
Kodda özellikle açıklama ekledim. Rengi silmek istemezseniz renk satırını kaldırabilirsiniz. Eğer sadece belli renkdeki hücreleri silsin istiyorsanız o zaman hucre.Interior.Color = vbYellow or hucre.Interior.Color = vblightGreen or hucre.Interior.Color = vbBlue then
şeklinde deneyin.İlk belirttiğim bu şekilde idi.
 
Sayın Korhan Bey, hayırlı geceler.

6 mesajınızdaki aşağıdaki kod hücrenin renk sayısını veriyor.

Kod: 
Sub Renk_Kodu()
    MsgBox ActiveCell.Interior.Color
End Sub

Ekrana gelecek mesajda örneğin Hücrenin rengi RGB(120, 12, 34) bu şekilde yazılabilir mi?
 
Aşağıdaki gibi deneyiniz.

Kod: 
Sub Renk_Kodu()
    Renk = ActiveCell.Interior.Color
    MsgBox "Hücrenin Rengi ;" & vbNewLine & vbNewLine & _
           "RGB(" & (Renk Mod 256) & ", " & ((Renk \ 256) Mod 256) & ", " & (Renk \ 65536) & ")"
End Sub
 
Sayın Korhan Bey, ellerinize sağlık çok teşekkür ederim.

Hayırlı geceler, hayırlı çalışmalar diliyorum.
 
İyi akşamlar.
Sub Temizle()
For t = 1 To Sheets.Count
Sheets(t).Select
For Each Hucre In [F3:G112]

If Hucre.Interior.Color = RGB(255, 245, 238) Then Hucre.ClearContents
Next
Next

End Sub
bu kod ile sorunu çözdüm.Ancak birleştirilmiş hücrelerde sorun oluyor.
 
Aşağıdaki kodu deneyiniz.

Kod: 
Sub Temizle()
    Dim Hucre As Range
    For t = 1 To Sheets.Count
        Sheets(t).Select
        For Each Hucre In [F3:G112]
            If Hucre.Interior.Color = RGB(255, 245, 238) Then
                If Hucre.MergeCells Then
                    Hucre.MergeArea.ClearContents
                Else
                    Hucre.ClearContents
                End If
            End If
        Next
    Next
End Sub
 
Sayın :Korhan Ayhan
kod çalıştı istediğimiz oldu.
Aynı klasör içindeki yaklaşık 35 adet çalışma sayfasındaki verileri makro ile silebilir miyiz?
 

Ekli dosyalar

Aşağıdaki kodu kullanabilirsiniz.

Aynı klasör içine bir excel dosyası oluşturup kodu uygulayıp deneyiniz.

Kod: 
Sub Temizle()
    Dim Yol As String, Dosya As Variant, K1 As Workbook
    Dim Sayfa As Worksheet, Hucre As Range, Say As Integer
    
    Application.ScreenUpdating = False
    
    Yol = ThisWorkbook.Path & "\*.xls*"
    
    Dosya = Dir(Yol)
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Set K1 = Workbooks.Open(Dosya, False, False)
            For Each Sayfa In K1.Worksheets
                For Each Hucre In Sayfa.Range("F3:G112")
                    If Hucre.Interior.Color = RGB(255, 245, 238) Then
                        Say = Say + 1
                        If Hucre.MergeCells Then
                            Hucre.MergeArea.ClearContents
                        Else
                            Hucre.ClearContents
                        End If
                    End If
                Next
            Next
            K1.Close 0
        End If
        Dosya = Dir
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "Temizlenen hücre sayısı ; " & Say, vbInformation
End Sub


Eğer klasörü seçerek işlem yapmak isterseniz aşağıdaki kodu kullanabilirsiniz.

Kod: 
Sub Temizle()
    Dim Klasör As Object, Yol As String, Dosya As Variant, K1 As Workbook
    Dim Sayfa As Worksheet, Hucre As Range, Say As Integer
    
    Application.ScreenUpdating = False
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
    If Not Klasör Is Nothing Then
        Yol = Klasör.Items.Item.Path & "\"
        
        Dosya = Dir(Yol)
        While Dosya <> ""
            If Dosya <> ThisWorkbook.Name Then
                Set K1 = Workbooks.Open(Dosya, False, False)
                For Each Sayfa In K1.Worksheets
                    For Each Hucre In Sayfa.Range("F3:G112")
                        If Hucre.Interior.Color = RGB(255, 245, 238) Then
                            Say = Say + 1
                            If Hucre.MergeCells Then
                                Hucre.MergeArea.ClearContents
                            Else
                                Hucre.ClearContents
                            End If
                        End If
                    Next
                Next
                K1.Close 0
            End If
            Dosya = Dir
        Wend
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbNewLine & "Temizlenen hücre sayısı ; " & Say, vbInformation
End Sub
 
İyi akşamlar.
Sub Temizle()
Dim Yol As String, Dosya As Variant, K1 As Workbook
Dim Sayfa As Worksheet, Hucre As Range, Say As Integer

Application.ScreenUpdating = False

Yol = ThisWorkbook.Path & "\*.xls*"

Dosya = Dir(Yol)
While Dosya <> ""
If Dosya <> ThisWorkbook.Name Then
Set K1 = Workbooks.Open(Dosya, False, False)
For Each Sayfa In K1.Worksheets
For Each Hucre In Sayfa.Range("F3:G112")
If Hucre.Interior.Color = RGB(255, 245, 238) Then
Say = Say + 1
If Hucre.MergeCells Then
Hucre.MergeArea.ClearContents
Else
Hucre.ClearContents
End If
End If
Next
Next
K1.Close 0
End If
Dosya = Dir
Wend

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "Temizlenen hücre sayısı ; " & Say, vbInformation
End Sub
Birden fazla sütunlar da ( a:b-f::g-k:l gibi ) temizleme işlemi için yukarıdaki kodlarda ne gibi değişiklik yapılmalı?
 
Kod içindeki aşağıdaki satırı değiştirmelisiniz.

Kod: 
For Each Hucre In Sayfa.Range("F3:G112")

Üstteki satırı aşağıdaki gibi yazabilirsiniz.

Kod: 
For Each Hucre In Sayfa.Range("F3:G112,K3:L112")
 
İyi akşamlar.
Çalışma sayfasındaki buton ile f g sütünları temizlene biliyor .Ancak K sütunu temizlenmiyor.
Kodlarda hata nerededir.?
 

Ekli dosyalar

Merhaba.
Belgenizde bir'den fazla sayıda silme/temizleme kodu var sanırım.
AÇIKLAMA isimli sayfadaki DÜĞME ile ilişkilendirilmiş olan kod Module5'deki Düğme1_Tıklat makrosu.
Module5'te yer alan bu kodun içerisindeki döngü başlangıcındaki alan adresini For Each Hucre In Range("F3:G112, K3:L112")
kısmını düzeltmeniz gerekiyor.
.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst