- Katılım
- 12 Şubat 2014
- Mesajlar
- 223
- Excel Vers. ve Dili
- office2013
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A8:A1000")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target <> "" Then
Dim Resim, ResimAdi, Adress
On Error Resume Next
For Each Resim In ActiveSheet.Shapes
Adress = Resim.TopLeftCell.Row
If Target.Row = Adress Then
Resim.ShapeRange.LockAspectRatio = msoFalse
Resim.Delete
Exit For
End If
Next
For Each Resim In Sheets("detay").Shapes
Adress = Resim.TopLeftCell.Column
If Adress = 2 Then
ResimAdi = Sheets("detay").Cells(Resim.TopLeftCell.Row, 1).Value
If ResimAdi = Target Then
If Left(Resim.Name, 7) <> "Control" Then
Resim.Copy
ActiveSheet.Paste Destination:=Cells(Target.Row, 6)
With Cells(Target.Row, 6)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Height = .MergeArea.Height - 4
Selection.Width = .MergeArea.Width - 4
Selection.Top = .Top + 2
Selection.Left = .Left + 2
Selection.Placement = xlMoveAndSize
End With
Target.Select
Exit Sub
End If
End If
End If
Next
End If
End Sub
çok teşekkürler