Excelde Kayan Ekran

[redje]

Sub HareketliYazi()
Dim int1 As Integer, bitir
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("A1") = Space(int1) & "suzunkopru"
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("A1") = Empty
End Sub


sayın leventm göndermiş olduğunuz örneği daha önce incelemiştim
bana en yatkın bu örnek hem basit hemde kısa oluşu


benim amacım vizite programında b2 sütununa sicili girip entere bastığımda d5 sütunundaki yazı kaysinki kişinin dikkatini çeksin
sürekli olursa daha iyi olur bu örnek birkez yazıyor kalıyor
diğer isteğimde suzun köprü yazısının oraya değilde c2 hücresindeki yazı gelsin istiyorum

bu şekilde oluşu mümkünse yardımcı olursanız sevinirim

 

[Levent Menteşoğlu]

Aşağıdaki şekilde deneyin o zaman. Kodu sayfanın kod sayfasına kopyalayın. B2 hücresi değiştiğinde çalışır.
[vb:1:4f3b399976]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
10 For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty
GoTo 10
End Sub
[/vb:1:4f3b399976]

 

[redje]

sayın leventm
çok teşekkür ederim her 2 makroyuda ayrı yerlerde kendi programıma uyarlayıp uygulamaya başladım
ancak aklıma her 2 makroyuda aynı anda uygulamak geldi alta yaptım fakat renk güzel çalışıyor döngü bi türlü durmuyor nerde yanlış yaptık anlamadım

bu şekilde olabilirmi yardımların için şimdiden çok teşekkürler

1. ci makro


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
10 For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty
GoTo 10
End Sub


2.ci makro

Dim e, f, c, d
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$B$2" Then
c = c + 1
Range("B11:C18").Select
Selection.Interior.ColorIndex = c + 2
Target.Select
End If
If Target.Address = "$B$5" Then
d = d + 1
Range("D11:E18").Select
Selection.Interior.ColorIndex = d + 2
Target.Select
End If
end sub




birleşmiş olarak yapılan makro



Dim e, f, c, d
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$B$2" Then
c = c + 1
Range("B11:C18").Select
Selection.Interior.ColorIndex = c + 2
Target.Select
End If
If Target.Address = "$B$5" Then
d = d + 1
Range("D11:E18").Select
Selection.Interior.ColorIndex = d + 2
Target.Select
End If

If Intersect(Target, [b2]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
10 For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty
GoTo 10
End Sub

 

[redje]

bir sorumu daha eklemeyi unuttum kayan makroda soldan başlıyor sağdan başlaması için ne yapmak gerekir

 

[Levent Menteşoğlu]

Döngü sonsuz olduğundan durmayacaktır. Fakat herhangi bir hücreye bir harf veya sayı yazıp entere bastığınızda durması gerekir.

 

[redje]

leventm anladım bende döngüyü kaldırdım
son bir isteğim daha olacak

sayfa1 de alttaki makro var ben birtane daha eklemek istiyorum
b5 e de yazdığımda d6 ya c3 teki bilgiler yazsın istiyorum

aynısın çoğaltıp alta ekledim olmadı

yardımların için teşekkürler


If Intersect(Target, [b2]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki gibi düzenleyin.

[vb:1:ebab7877bb]If Intersect(Target, [b5]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("d6") = Space(int1) & [c3]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d6") = Empty
End Sub[/vb:1:ebab7877bb]

 

[redje]

pardon yanlış anlattım sanırım

benim istediğim altta yaptım b2 oluyor b5 olmuyor

bunu çözersen sevinirim


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty

If Intersect(Target, [b5]) Is Nothing Then Exit Sub

For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D6") = Space(int1) & [c3]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d6") = Empty
End Sub

 

[redje]

sayın leventm

çok yerini değiştirdim denedim olmadı aşağıdaki birleitirmeyi yapamadım b2 değiştiğinde oluyor b5 değiştiğinde olmuyor bu şekilde mümkünmü



Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2]) Is Nothing Then Exit Sub
Dim int1 As Integer, bitir
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty

If Intersect(Target, [b5]) Is Nothing Then Exit Sub

For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D6") = Space(int1) & [c3]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d6") = Empty
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

[vb:1:c02fbe658d]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
Dim int1 As Integer, bitir
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D5") = Space(int1) & [c2]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d5") = Empty
End If
If Target.Address = "$B$5" Then
For int1 = 1 To 20
bitir = Timer + 0.1
Do
Range("D6") = Space(int1) & [c3]
DoEvents
Loop While Timer < bitir
DoEvents
Next int1
Range("d6") = Empty
End If
End Sub[/vb:1:c02fbe658d]

 

[redje]

sayın leventm

çok teşekkür ederim çok güzel oldu kendime göre uyarladım mümkünse bir ufak sorum daha olacak en son hali ile soldan başlıyor kayma işlemi
sağdan sola doğruda olabilirmi

 

[Levent Menteşoğlu]

[vb:1:d1de075fa6]For int1 = 1 To 20
[/vb:1:d1de075fa6]

Yukarıdaki satırları aşağıdaki ile değiştirin.

[vb:1:d1de075fa6]For int1 = 20 To 1 Step -1
[/vb:1:d1de075fa6]

 

[Korhan Ayhan]

Selamlar,

WebBrowser üzerinde yazı karakterine,rengine ve fontuna nasıl müdahale edebilirim.

 

[chevmet]

elinize sağlık

 

[esolen]

2 yılönce bu başlığı ben açtım işim bittikten sonra kullanmadım
bilgisayarımdada bulamadım örnek dosyayı rica etsem örnek dosyayı ekleye bilirmiisniz Selamlar