Macro nedenli, geri alma ve kopyalama sorunu.

[ultrademox]

Selam arkadaşlar,

Excel sayfam için aşağıdaki gibi bir örnekleme yaptım. Fakat şöyle bir sıkıntı var. Excel sayfasında macro her cursor basımında çalıştığı için; geri al, kopyala vb. araçları kullanamıyorum. Bunun çözümü için yardımlarınızı rica ediyorum.

----------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim HA, DR, YDR

HA = Range("IV1").Value
Range("IV2").Value = UCase(Range(HA).Value)
EDR = Range("IV2").Value
YDR = Range("IV3").Value

If EDR = "RT" Then
With Range(HA).Interior
.ColorIndex = 37
Pattern = xlSolid
End With
Range(HA).Value = UCase(Range(HA).Value)
With Range(HA).Offset(-1, 0).Interior
.ColorIndex = 37
Pattern = xlSolid
End With
End If

End sub
----------------------------------------------------------------

 

[Levent Menteşoğlu]

Kodun en üstüne aşağıdaki mavi renkli satırları ilave edin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim HA, DR, YDR
 
[B][COLOR=blue]deg=application.cutcopymode[/COLOR][/B]
[B][COLOR=blue]if deg=1 or deg=2 then exit sub[/COLOR][/B]
 
HA = Range("IV1").Value
Range("IV2").Value = UCase(Range(HA).Value)
EDR = Range("IV2").Value
YDR = Range("IV3").Value
 
If EDR = "RT" Then
With Range(HA).Interior
.ColorIndex = 37
Pattern = xlSolid
End With
Range(HA).Value = UCase(Range(HA).Value)
With Range(HA).Offset(-1, 0).Interior
.ColorIndex = 37
Pattern = xlSolid
End With
End If
 
End sub

 

[ultrademox]

Dikkate almadı

Levent bey, anlamadığım benim kod satırımın en altı
-
Range("IV1").Value = ActiveCell.Address
Range("IV3").Value = ActiveCell.Value
-
ile bitmesine ve hücrelere veri yazmasına rağmen cutcopymode bozulmuyor.
Anladığım kadarıyla if'in true olmasına bağlı bir bozulma var. Geri almanın yada cutcopymode un bozulma nedeni hakkında bilgi verirmisiniz?

 

[Levent Menteşoğlu]

Yukarıdaki kodda arada bir nokta unutmuşum tekrar deneyin. Kopyalamanın bozulması gayet doğal çünkü her seferinde sadece bir işlem yapılır. Siz kopyalama yapsanız bile bir başka hücre seçtiğinizde kod devreye girdiğinden kopyalama işlemini iptal ediyor.

 

[ultrademox]

Bir nokta

Asıl anlamadığım ben her hücre gezişimde activecell value'yu bir hücreye yazdırırken kopyalamanın bozulmaması. Sadece if'lerin true olması halinde kopyalama bozuluyor. Bende şöyle bir eklenti yaptım şimdilik işe yaradı. Kodların tümü aşağıdadır;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim HA, DR, YDR, DEG

HA = Range("IV1").Value
Range("IV2").Value = UCase(Range(HA).Value)
EDR = Range("IV2").Value
YDR = Range("IV3").Value

If YDR = "YG" Or YDR = "P" Or _
YDR = "RT" Or YDR = "Üİ" Or _
YDR = "ÜZİ" Or YDR = "ÜR" Or _
YDR = "ÜZR" Then
GoTo Line1
End If

If EDR = "RT" Then
With Range(HA).Interior
.ColorIndex = 37
Pattern = xlSolid
End With
Range(HA).Value = UCase(Range(HA).Value)
With Range(HA).Offset(-1, 0).Interior
.ColorIndex = 37
Pattern = xlSolid
End With
End If

If EDR = "P" Then
With Range(HA).Interior
.ColorIndex = 35
Pattern = xlSolid
End With
Range(HA).Value = UCase(Range(HA).Value)
With Range(HA).Offset(-1, 0).Interior
.ColorIndex = 35
Pattern = xlSolid
End With
End If

If EDR = "YG" Then
With Range(HA).Interior
.ColorIndex = 40
Pattern = xlSolid
End With
Range(HA).Value = UCase(Range(HA).Value)
With Range(HA).Offset(-1, 0).Interior
.ColorIndex = 40
Pattern = xlSolid
End With
End If

If EDR = "TG" Then
Range(HA).Value = UCase(Range(HA).Value)
Range(HA).Interior.ColorIndex = xlNone
Range(HA).Font.Bold = False
Range(HA).Font.ColorIndex = 0
With Range(HA).Offset(-1, 0).Interior
.ColorIndex = xlNone
Range(HA).Offset(-1, 0).Font.ColorIndex = 0
Range(HA).Offset(-1, 0).Font.Bold = False
End With

End If

If EDR = "ÜI" Then
Range(HA).Value = "Üİ"
Range(HA).Font.Bold = True
Range(HA).Font.ColorIndex = 3
End If

If EDR = "ÜZI" Then
Range(HA).Value = "ÜZİ"
Range(HA).Font.Bold = True
Range(HA).Font.ColorIndex = 3
End If

If EDR = "Üİ" Or EDR = "ÜZİ" Or EDR = "ÜR" Or EDR = "ÜZR" Then
Range(HA).Value = UCase(Range(HA).Value)
Range(HA).Font.Bold = True
Range(HA).Font.ColorIndex = 3
End If

Line1:
If EDR = "" And YDR = "YG" Or _
EDR = "" And YDR = "P" Or _
EDR = "" And YDR = "RT" Or _
EDR = "" And YDR = "Üİ" Or _
EDR = "" And YDR = "ÜZİ" Or _
EDR = "" And YDR = "ÜR" Or _
EDR = "" And YDR = "ÜZR" Then
Range(HA).Interior.ColorIndex = xlNone
Range(HA).Offset(-1, 0).Interior.ColorIndex = xlNone
End If

If EDR = "" And YDR = "Üİ" Or _
EDR = "" And YDR = "ÜZİ" Or _
EDR = "" And YDR = "ÜR" Or _
EDR = "" And YDR = "ÜZR" Then
Range(HA).Font.ColorIndex = 0
Range(HA).Font.Bold = False
End If

Range("IV1").Value = ActiveCell.Address
Range("IV3").Value = ActiveCell.Value
End Sub
----------------------------------------------
Bir nokta unutmuşum demiştiniz, unutulan nokta ile ilgili denemem gereken yeni durumu göndermediniz yada yanlış sizi anladım. Alternatif bir çözümünüz var ise belirmenizi rica ederim. İlginiz için teşekkür ediyorum.

 

[ultrademox]

Pardon

Noktadan kasıt . imiş özür

 

[ultrademox]

Levent Bey sanırım undo için bir çözüm yok