Resim sığdırma

[serkan.sevinc]

Merhaba,

F2 den aşağıya doğru ve G2 den aşağıya doğru hücrelerin içinde resimler bulunmaktadır. Bu resimlerin bulunduğu hücreboyutu ile aynı olmasını istiyorum. Yardımcı olabilir misiniz?

 

[Korhan Ayhan]

Merhaba,

Faydalı olabilir...

Arşiv Konuları

 

[serkan.sevinc]

yapamadım

 

[nihatkr]

Dosyanızı ekleseniz daha kolay olurdu.

Resimleri nerden alacak? yada hücrede olan resmi hücreyemi sığdıracak?

Sub ResmiHucreseyeSigdir()
Dim ws As Worksheet
Dim pic As Picture
Dim resimYolu As String
Dim targetCell As Range

resimYolu = "C:\DosyaYolu\resim.jpg" ' <-- burayı kendi resim yolunla değiştir

Set ws = ActiveSheet
Set targetCell = ws.Range("A1")

Set pic = ws.Pictures.Insert(resimYolu)

' Hücreye göre konumlandır ve boyutlandır
With pic
.Left = targetCell.Left
.Top = targetCell.Top
.Width = targetCell.Width
.Height = targetCell.Height
.Placement = xlMoveAndSize
End With
End Sub

 

[serkan.sevinc]

F2 den ve G2 de aşağıya doğru resimler var. Resimleri bulunduğu hücreye göre tam sığdıracak
Örnek
F2-F3-F4-F5-F6-F7....
G2-G3-G4-G5-G6-G7....

 

[nihatkr]

Deneyiniz ....


Sub ResimleriHucreyeSigdir()
Dim ws As Worksheet
Dim pic As Shape
Dim cellF As Range, cellG As Range
Dim lastRow As Long

Set ws = ActiveSheet

lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
If ws.Cells(ws.Rows.Count, "G").End(xlUp).Row > lastRow Then
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
End If

For Each cellF In ws.Range("F2:F" & lastRow)
For Each pic In ws.Shapes
If Not Intersect(pic.TopLeftCell, cellF) Is Nothing Then
With pic
.LockAspectRatio = msoFalse
.Left = cellF.Left
.Top = cellF.Top
.Width = cellF.Width
.Height = cellF.Height
End With
End If
Next pic
Next cellF

For Each cellG In ws.Range("G2:G" & lastRow)
For Each pic In ws.Shapes
If Not Intersect(pic.TopLeftCell, cellG) Is Nothing Then
With pic
.LockAspectRatio = msoFalse
.Left = cellG.Left
.Top = cellG.Top
.Width = cellG.Width
.Height = cellG.Height
End With
End If
Next pic
Next cellG
End Sub

 

[serkan.sevinc]

ÖNCELİKLER ÇOK TEŞEKKÜR EDERİM.
F2 ve G2 yi yaptı fakat altındaki hücreleri değiştirmedi

 

[nihatkr]

ÖNCELİKLER ÇOK TEŞEKKÜR EDERİM.
F2 ve G2 yi yaptı fakat altındaki hücreleri değiştirmedi

Bunu Deneyiniz

Sub TumResimleriHucreyeSigdir()
Dim ws As Worksheet
Dim shp As Shape
Dim lastRowF As Long, lastRowG As Long
Dim lastRow As Long

Set ws = ActiveSheet

lastRowF = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
lastRowG = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
If lastRowF > lastRowG Then
lastRow = lastRowF
Else
lastRow = lastRowG
End If

For Each shp In ws.Shapes

If shp.Type = msoPicture Then
If shp.TopLeftCell.Column = 6 Or shp.TopLeftCell.Column = 7 Then ' 6=F, 7=G
If shp.TopLeftCell.Row >= 2 And shp.TopLeftCell.Row <= lastRow Then
With shp
.LockAspectRatio = msoFalse
.Left = shp.TopLeftCell.Left
.Top = shp.TopLeftCell.Top
.Width = shp.TopLeftCell.Width
.Height = shp.TopLeftCell.Height
End With
End If
End If
End If
Next shp
End Sub

 

[serkan.sevinc]

Bu hiç birini yapmadı

 

[nihatkr]

Bu hiç birini yapmadı

Bu Kodu Ben Test Ettim Çalışıyor

Sub ResimleriFveGHucrelereSigdir()
Dim ws As Worksheet
Dim shp As Shape
Dim rng As Range

Set ws = ActiveSheet

Dim lastRowF As Long, lastRowG As Long, lastRow As Long
lastRowF = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
lastRowG = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
lastRow = Application.Max(lastRowF, lastRowG)

Set rng = ws.Range("F2:G1500" & lastRow)

For Each shp In ws.Shapes
If shp.Type = msoPicture Then
If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
With shp
.LockAspectRatio = msoFalse
.Left = .TopLeftCell.Left
.Top = .TopLeftCell.Top
.Width = .TopLeftCell.Width
.Height = .TopLeftCell.Height
End With
End If
End If
Next shp
End Sub

 

[serkan.sevinc]

çok teşekkürler

 

[nihatkr]

çok teşekkürler

Sanırım Çözüme Kavuştu.