• DİKKAT

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

sanırım sürekli makro çalışıyor. geri al aktif olmuyor.

E

euphrates55

Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("formfrt").Select
yol = ThisWorkbook.Path & "\haritalar\"

Rem aralıktaki resmi sil
Set alan = Range("k5:t20")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(1, "V").Value & ".png") <> "" Then
dosya = "\" & Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(5, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If





Sheets("formfrt").Select
yol = ThisWorkbook.Path & "\fotoğraflar1\"

Rem aralıktaki resmi sil
Set alan = Range("c27:j31")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(1, "V").Value & ".jpg") <> "" Then
dosya = "\" & Cells(1, "V").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(27, "c")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If




Sheets("formfrt").Select
yol = ThisWorkbook.Path & "\fotoğraflar2\"

Rem aralıktaki resmi sil
Set alan = Range("l27:t31")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(1, "V").Value & ".jpg") <> "" Then
dosya = "\" & Cells(1, "V").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(27, "l")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If






Sheets("formfrt").Select
yol = ThisWorkbook.Path & "\itinererler\"

Rem aralıktaki resmi sil
Set alan = Range("c32:t32")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(1, "V").Value & ".png") <> "" Then
dosya = "\" & Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(32, "c")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If









Set a = Sheets("formfrt")

If a.[c40] >= 0 And a.[c40] < 300 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 28


ElseIf a.[c40] >= 301 And a.[c40] < 400 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 26

ElseIf a.[c40] >= 401 And a.[c40] < 500 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 24


ElseIf a.[c40] >= 501 And a.[c40] < 600 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 22


ElseIf a.[c40] >= 601 And a.[c40] < 700 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 20

ElseIf a.[c40] >= 701 And a.[c40] < 800 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 17


ElseIf a.[c40] >= 801 And a.[c40] < 1000 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 18


ElseIf a.[c40] >= 1001 And a.[c40] < 1200 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 16


ElseIf a.[c40] >= 1201 And a.[c40] < 1400 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 14


ElseIf a.[c40] >= 1401 And a.[c40] < 1600 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 13

ElseIf a.[c40] >= 1601 Then
a.[c33].Font.Name = "Palatino Linotype"
a.[c33].Font.Size = 9
End If
End Sub

uzun bir kodum var ve bu sayfada bir şeyler yaptığımda geri al tuşu aktif olmuyor. sebebi ise sanırım sürekli makro çalışıyor. bunun önüne geçebilir miyim?
 
Merhaba,
Kodun en başında yer alan Private Sub Worksheet_Change(ByVal Target As Range) satırını Sub Kod() şeklinde değiştirebilirsiniz.
 
Bu detayı daha önce söylemediniz ama...
Kodun en başını aşağıdaki şekilde düzenlerseniz V1 hücresinde değişiklik yapıldığında kod çalışır.
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("V1")) Is Nothing Then Exit Sub
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
.
.
.
 
ÖmerBey' Alıntı:
Bu detayı daha önce söylemediniz ama...
Kodun en başını aşağıdaki şekilde düzenlerseniz V1 hücresinde değişiklik yapıldığında kod çalışır.
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("V1")) Is Nothing Then Exit Sub
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
.
.
.
Genişletmek için tıkla ...
tekrar teşekkürler...
 
Rica ederim, iyi çalışmalar...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst