Boş Hücrelerdeki Açıklamaları Bulma

[hakki83]

Merhabalar

Örnek dosyada ÇALIŞMA sayfasında

D7
K12
G3
L3

hücrelerinde açıklamalar (açıklama kutuları) vardır.

Bu açıklama kutularının hepsini Ctrl+F ile bulmak mümkün.

Fakat ihtiyacım olan, sadece D7 ve K12 deki açıklamaların olduğu hücreleri bulmak istiyorum. Çünkü o hücreler boş.

Yani kısacası boş hücrelerde bulunan, silmeyi unutuğumuz açıklama kutuları var mu yok mu, bunu bulmak istiyorum.

Fakat bunu ÇALIŞMA sayfasına dökmemeli. Çünkü sayfada uygun yer yok. Diğer RAPOR sayfasına Msgbox ile sonuçlar gösterilirse, ya da yine RAPOR sayfasına M sütununa dökülürse olabilir.

Teşekkürler.

 

[Haluk]

Sub Test()
    Set Rng = Sheets("Çalışma").Cells.SpecialCells(xlCellTypeComments)
    
    For Each xRng In Rng
        If xRng = "" Then
            j = j + 1
            Sheets("Rapor").Range("M" & j) = xRng.Address
        End If
    Next
End Sub

.

 

[hakki83]

Sub Test()
    Set Rng = Sheets("Çalışma").Cells.SpecialCells(xlCellTypeComments)
   
    For Each xRng In Rng
        If xRng = "" Then
            j = j + 1
            Sheets("Rapor").Range("M" & j) = xRng.Address
        End If
    Next
End Sub

.

Hocam çok teşekkürler, emeğinize sağlık, fakat hata bende belirtmeyi unuttum,
1. satır başlık olduğu için M2’den itibaren dökmesi için kodlarda nereyi değiştirmeliyim.

 

[Haluk]

Kodun en başına,

j=1

yazın...

.

 

[Korhan Ayhan]

Döngüsüz alternatif..

Option Explicit

Sub Test()
    Dim Comment_Cells As Range, Blank_Cells As Range, Rng As Range
   
    Set Comment_Cells = Sheets("ÇALIŞMA").Cells.SpecialCells(xlCellTypeComments)
    Set Blank_Cells = Sheets("ÇALIŞMA").Cells.SpecialCells(xlCellTypeBlanks)
    Set Rng = Intersect(Comment_Cells, Blank_Cells)
    
    Sheets("RAPOR").Range("M2:M" & Rows.Count).ClearContents
    Sheets("RAPOR").Range("M2").Resize(UBound(Split(Rng.Address, ",")) + 1).Value = Application.Transpose(Split(Rng.Address, ","))
End Sub

 

[hakki83]

Hocam teşekkürler emeğinize sağlık. Bunu M2 den başlatabilir miyiz?

 

[Korhan Ayhan]

Üstte ki mesajımda gerekli revizeyi yaptım. Deneyiniz.

 

[hakki83]

Döngüsüz alternatif..

Option Explicit

Sub Test()
    Dim Comment_Cells As Range, Blank_Cells As Range, Rng As Range
  
    Set Comment_Cells = Sheets("ÇALIŞMA").Cells.SpecialCells(xlCellTypeComments)
    Set Blank_Cells = Sheets("ÇALIŞMA").Cells.SpecialCells(xlCellTypeBlanks)
    Set Rng = Intersect(Comment_Cells, Blank_Cells)
   
    Sheets("RAPOR").Range("M2:M" & Rows.Count).ClearContents
    Sheets("RAPOR").Range("M2").Resize(UBound(Split(Rng.Address, ",")) + 1).Value = Application.Transpose(Split(Rng.Address, ","))
End Sub

Korhan hocam merhaba

Ardışık açıklamaları aralarında : işaretiyle tek hücreye döküyor,
Acaba normal şekilde dökülecek şekilde düzeltebilir misiniz, teşekkürler.

 

[Korhan Ayhan]

Bu durumda Haluk beyin önerdiği döngüyü kullanmanız gerekir.