Hücreye sayı olarak 2 değer ve üzeri değere koşul atama

[aykut12344]

Hücreyi Koşullu Düzenleme [Biraz Acil]

Arkadaşlar ;

D sütununa 2 ve üzeri sayı değerleri girildiğinde altındaki hücrelere girildiği değer kadar hücreye aynı rakamın yazmasını istiyorum. Örnek olarak resimdeki gibi 4 değeri yazılan hücreyle birlikte altına 3 tane daha 4 eklenerek toplamda sutunda 4 tane 4 rakamı olsun istiyorum.

 

[antonio]

Arkadaşlar ;

D sütununa 2 ve üzeri sayı değerleri girildiğinde altındaki hücrelere girildiği değer kadar hücreye aynı rakamın yazmasını istiyorum. Örnek olarak resimdeki gibi 4 değeri yazılan hücreyle birlikte altına 3 tane daha 4 eklenerek toplamda sutunda 4 tane 4 rakamı olsun istiyorum.

Sayfa sekmesine sağ tıklayıp, "Kod Görüntüle" yi seçin ve açılan pencereye aşağıdaki kodu yapıştırın

Private Sub Worksheet_Change(ByVal Target As Range)
Dim girilen As Byte
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("d1:d" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub

girilen = Target.Value
For i = 2 To girilen

Range("D" & Target.Row & ":D" & Target.Row + (girilen - 1)).Value = girilen
Next
End If
Application.EnableEvents = True
End Sub

 

[aykut12344]

Sayfa sekmesine sağ tıklayıp, "Kod Görüntüle" yi seçin ve açılan pencereye aşağıdaki kodu yapıştırın

Private Sub Worksheet_Change(ByVal Target As Range)
Dim girilen As Byte
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("d1:d" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub

girilen = Target.Value
For i = 2 To girilen

Range("D" & Target.Row & ":D" & Target.Row + (girilen - 1)).Value = girilen
Next
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
Cells(Target.Row, Target.Column + 4) = Date & " - " & Time
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim girilen As Byte
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("d1:d" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub

girilen = Target.Value
For i = 2 To girilen

Range("D" & Target.Row & "" & Target.Row + (girilen - 1)).Value = girilen
Next
End If
Application.EnableEvents = True
End Sub

Kodlarını aynı anda aynı sayfada çalışmıyor neden acaba? birde bu sorunu nasıl çözerim

 

[Korhan Ayhan]

Sayfa olayına ait iki kodu birleştirmeniz gerekiyor. Aynı olaya ait birden fazla kodu aynı sayfa için kullanamazsınız.

 

[aykut12344]

Sayfa olayına ait iki kodu birleştirmeniz gerekiyor. Aynı olaya ait birden fazla kodu aynı sayfa için kullanamazsınız.

birleştirme olayını daha önce hiç yapmadım biraz denedim ama başarılı olmadım rica etsem yardımcı olabilir misiniz ?

 

[antonio]

birleştirme olayını daha önce hiç yapmadım biraz denedim ama başarılı olmadım rica etsem yardımcı olabilir misiniz ?

Dosyanızı ekleyin.

 

[aykut12344]

Dosyanızı ekleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
Cells(Target.Row, Target.Column + 4) = Date & " - " & Time
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim girilen As Byte
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("d1:d" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub

girilen = Target.Value
For i = 2 To girilen

Range("D" & Target.Row & "" & Target.Row + (girilen - 1)).Value = girilen
Next
End If
Application.EnableEvents = True
End Sub

Ortak çalıştırmaya çalıştığım kodlar bunlar Dosya olarak nasıl istiyorsunuz onu anlayamadım :/