[ÇÖZÜLDÜ] Sayfada Resim Olup Olmadığını Sorgulama

[BedriA]

Arkadaşlar,

Bir sayfada 8. satırdan başlayarak, F ve G hücrelerinde resim olup olmadığını denetleyecek,
her ikisinde de resim yoksa o satırı silecek, ikisinde de veya sadece herhangi birinde resim varsa
işlem yapmayacak bir koda ihtiyacım var.

Sayfaya resim attığım kodu da paylaşıyorum.
Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Sheets("20k").Select

If Sheets("20k").Range("a1") = "x" Then


If Intersect(Target, [D2:D100,G2:F100]) Is Nothing Then Exit Sub
yatay = 1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "png"
uzanti(5) = "jpeg"

For j = 1 To 5



dosya = ThisWorkbook.Path & "\Azmun\Sorular\" & Target.Value & "." & uzanti(Val(j))

If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
ad = s1.Pictures.Insert(dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse

s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 3
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 3
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 50
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 30
s1.Shapes(ad).OLEFormat.Object.Name = Target.Address
s1.Cells(Target.Row + 1, Target.Column).Select


Exit For
End If
Next
End If

Else

Exit Sub
End If

End Sub

 

[Asri]

resim olduğu için sonsatir tespitini sizin belirtmeniz gerekiyor.

1- Belirtilen aralıktaki hücrelerin değerlerini siler
2- Resim olan hücrelere 1 değerini verir.
3- Her iki hücrede de 1 değeri yok ise o satırı siler.
4- Belirtilen aralıktaki hücrelerin değerlerini siler

Sub bos_satir_sil()
  Dim sTemp As String
  Dim sShape As Shape
  Dim MyRange As Range
  
[COLOR=Red]  sonsatir = 20[/COLOR]
  
  alan = "F8:G" & sonsatir
  Range(alan).ClearContents
  On Error Resume Next
  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), Range(alan)) Is Nothing Then
       Range(sShape.TopLeftCell.Address) = 1
    End If
  Next

  For i = sonsatir To 8 Step -1
    If Cells(i, "F") = "" And Cells(i, "G") = "" Then
      Rows(i).Delete
    End If
  Next i
   Range(alan).ClearContents
End Sub

 

[BedriA]

Çok teşekkür ederim Asri Hocam.

 

[Ömer BARAN]

Merhaba.

Umarım bir hata yoktur.
Ben de aşağıdaki gibi düşünmüştüm.
Kod sadece resimleri siler, hücre/satır/sütun silinmez.
.

[B]Sub RESIM_SIL()[/B]
Dim resim As shape
For Each resim In ActiveSheet.Shapes
    a = resim.Left: b = resim.Top
    For sut = 6 To 7
        For brn = 8 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
            For k = 1 To sut - 1
                sol = sol + Cells(1, k).Width
                solresim = a + Cells(1, sut - 1).Width
            Next
            For sat = 1 To brn - 1
                ust = ust + Cells(sat, sut).Height
                ustresim = b + Cells(sat, sut).Height
            Next
        sol1 = sol: sol2 = sol1 + Cells(1, k + 1).Width
        ust1 = ust: ust2 = ust1 + Cells(brn, sut - 1).Height
        If sol1 <= a And solresim >= a And ust1 <= b And ustresim >= b Then
           ActiveSheet.Shapes.Range(Array(resim.Name)).Delete
           GoTo 10
        End If
    solresim = 0: ustresim = 0: sol = 0: ust = 0: sol1 = 0: sol2 = 0: ust1 = 0: ust2 = 0
        Next
    Next
10: Next
[B]End Sub[/B]

 

[BedriA]

resim olduğu için sonsatir tespitini sizin belirtmeniz gerekiyor.

1- Belirtilen aralıktaki hücrelerin değerlerini siler
2- Resim olan hücrelere 1 değerini verir.
3- Her iki hücrede de 1 değeri yok ise o satırı siler.
4- Belirtilen aralıktaki hücrelerin değerlerini siler

Sub bos_satir_sil()
  Dim sTemp As String
  Dim sShape As Shape
  Dim MyRange As Range
  
[COLOR=Red]  sonsatir = 20[/COLOR]
  
  alan = "F8:G" & sonsatir
  Range(alan).ClearContents
  On Error Resume Next
  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), Range(alan)) Is Nothing Then
       Range(sShape.TopLeftCell.Address) = 1
    End If
  Next

  For i = sonsatir To 8 Step -1
    If Cells(i, "F") = "" And Cells(i, "G") = "" Then
      Rows(i).Delete
    End If
  Next i
   Range(alan).ClearContents
End Sub

Asri Hocam,

Satır sildikten sonra, alanı silmek kağıdın yapısını bozuyordu.
Onu silince de tam düzelmedi, ben biraz daha uğraşacağım.

Ayrıca; resimleri değil, aslında resim bulunmayan hücrenin hemen solundaki hücredeki veriyi silmeye yarayan bir koda ihtiyaç var.
Biraz daha detaylandırayım.

Sayfaya örneğin 10 numara atılıyor; bu 10 numaraya göre sayfaya resim alıyor otomatik.
Ama 10 numara atıldı ancak klasörde 8 soru var. Bu durumda sayfadaki 9 ve 10 numaralarının bulunduğu hücreleri
silmek istiyorum.

Resim aranacak son satır ise şu şekilde:

Son_Dolu_Satir = Sheets("20k").Range("G65536").End(3).Row -3

Olmazsa sizi kızdırmadan örnek dosya paylaşacağım.

Range(alan).ClearContents

 

[BedriA]

Merhaba.

Umarım bir hata yoktur.
Ben de aşağıdaki gibi düşünmüştüm.
Kod sadece resimleri siler, hücre/satır/sütun silinmez.
.

[B]Sub RESIM_SIL()[/B]
Dim resim As shape
For Each resim In ActiveSheet.Shapes
    a = resim.Left: b = resim.Top
    For sut = 6 To 7
        For brn = 8 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
            For k = 1 To sut - 1
                sol = sol + Cells(1, k).Width
                solresim = a + Cells(1, sut - 1).Width
            Next
            For sat = 1 To brn - 1
                ust = ust + Cells(sat, sut).Height
                ustresim = b + Cells(sat, sut).Height
            Next
        sol1 = sol: sol2 = sol1 + Cells(1, k + 1).Width
        ust1 = ust: ust2 = ust1 + Cells(brn, sut - 1).Height
        If sol1 <= a And solresim >= a And ust1 <= b And ustresim >= b Then
           ActiveSheet.Shapes.Range(Array(resim.Name)).Delete
           GoTo 10
        End If
    solresim = 0: ustresim = 0: sol = 0: ust = 0: sol1 = 0: sol2 = 0: ust1 = 0: ust2 = 0
        Next
    Next
10: Next
[B]End Sub[/B]

Ömer Hocam,

Teşekkür ederim.

"sol" değişkeninin tanımlanmasında bir hata var sanırım.
"sol" daha önce tanımlanmadan, yine kendisi yardımıyla tanımlanmaya çalışılıyor. "Compile Error" hatası veriyor.

Ayrıca; resimleri değil, aslında resim bulunmayan hücrenin hemen solundaki hücredeki veriyi silmeye yarayan bir koda ihtiyaç var.
Biraz daha detaylandırayım.

Sayfaya örneğin 10 numara atılıyor; bu 10 numaraya göre sayfaya resim alıyor otomatik.
Ama 10 numara atıldı ancak klasörde 8 soru var. Bu durumda sayfadaki 9 ve 10 numaralarının bulunduğu hücreleri
silmek istiyorum.

Resim aranacak son satır ise şu şekilde:

Son_Dolu_Satir = Sheets("20k").Range("G65536").End(3).Row -3

 

[BedriA]

Asri Hocam,

Sizin kodunuzda biraz değişiklik yaparak istediğim sonucu aldım.

Çok teşekkür ederim.

Sub bos_satir_sil()

Dim sTemp As String
  Dim sShape As Shape
  Dim MyRange As Range
  
  
  'E
  Sheets("20k").Select
  sonsatir = Sheets("20k").Range("E65536").End(3).Row - 2
  alan1 = "E8:E" & sonsatir
 

  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), Range(alan1)) Is Nothing Then
       Range(sShape.TopLeftCell.Address) = 1
    End If
  Next
  
  'G
  sonsatir1 = Sheets("20k").Range("G65536").End(3).Row - 3
  alan2 = "G8:G" & sonsatir
 

  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), Range(alan2)) Is Nothing Then
       Range(sShape.TopLeftCell.Address) = 1
    End If
  Next
  
  'Satırsil
 Sheets("20k").Select
 sonsatir = Sheets("20k").Range("G65536").End(3).Row - 3
  
  For a = sonsatir To 8 Step -1
    If Range("E" & a) = "" And Range("G" & a) = "" Then
      Rows(a).Delete
    End If
    
    If Range("G" & a) = "" Then
    Range("F" & a) = ""
    End If
    
  Next a
  
  
  
  'Silme
    Sheets("20k").Select
    sonsatir = Sheets("20k").Range("E65536").End(3).Row - 2
  alan1 = "E8:E" & sonsatir
 

  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), Range(alan1)) Is Nothing Then
       Range(sShape.TopLeftCell.Address) = ""
    End If
  Next
  
    Sheets("20k").Select
  sonsatir1 = Sheets("20k").Range("G65536").End(3).Row - 3
  alan2 = "G8:G" & sonsatir
 

  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), Range(alan2)) Is Nothing Then
       Range(sShape.TopLeftCell.Address) = ""
    End If
  Next

End Sub

 

[Ömer BARAN]

Tekrar merhaba.

Cevabı gönderdikten sonra bilgisayar başından kalkmıştım.
Söylediklerinizden hiçbir şey anlamadım.

Keşke bir örnek belge ekleseydiniz.
Ben boş bir belgeye, birkaçı F-G sütunlarında olmak üzere resimler ekledim ve
kodu çalıştırdığımda bir sorunla karşılaşmadım.

Herneyse sorununuzu çözmüşsünüz zaten.
Yine de elimde bir alternatif olsun derseniz bir örnek belge ekleyin, müsait olduğumda bakarım.

İyi çalışmalar.
.