HÜCREYE GİRİLEN RAKAMI ALT SATIRLARA KOPYALAMAK

mavi674 · Cumartesi saat 15:39'de

Selam değerli site üyeleri ve değerli hocalarım
K Sütununda çalışmalarım olacak. Örnekte de detaylı bir açıklama yaptım.
K Sütununda girdiğim sayıyı alt satırlara kopyalaması. Örnekte zaten bir macro var.
İstediğim bu çalışmayı da bu macroya dahil etmek.
Şimdiden Teşekkürlerimi sunarım, iyi ki varsınız....

İndir DENEME xls

Dosyayı indir DENEME xls

dosya.co

Muzaffer Ali · Cumartesi saat 15:53'de

Merhaba.
Dosyadaki kodu silip yerine aşağıdakini kopyalayın.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then
     'cancel = True
      If Target.Value <> 0 Then
          Target.Select
          sat = Target.Row
          
          If Cells(sat, 11) = "" Then
              Cells(sat, 11) = Target.Value
              'VİSA SIRA NO VERMEK İÇİN AŞAĞI SATIRI ÇALIŞTIR
              'Cells(sat - 1, 11) = 1
              
          ElseIf Cells(sat, Columns.Count) = Empty Then
                  sut = Cells(sat, Columns.Count).End(xlToLeft).Column
                  Cells(sat, sut + 1) = Target.Value
                  'VİSA SIRA NO VERMEK İÇİN AŞAĞI SATIRI ÇALIŞTIR
                  'Cells(sat - 1, sut + 1) = sut - 9
            End If
            Else
              'O GİRİNCE SİLMEK İÇİN
              sat = Target.Row
              sut = Cells(sat, Columns.Count).End(xlToLeft).Column
              Range(Cells(sat, 11), Cells(sat, sut)).ClearContents
              'ALT SATIR AKTİF OLURSA VİSANIN SIRA NOLARI SİLİNİR
              'Range(Cells(sat - 1, 11), Cells(sat - 1, sut)).ClearContents
    
     'Target.Select
     'If Target = 0 And Target <> "" Then
     'sat = Target.Row
     'sut = Cells(sat, Columns.Count).End(xlToLeft).Column
     'Range(Cells(sat, "L"), Cells(sat, "m")).ClearContents
        
      End If
      'sıfırlanınca imleç sabit durması için
      Target.Select
      'yazıldı
      Target.Value = ""
    ElseIf Not Intersect(Target, [K47:K767]) Is Nothing Then
        Range(Target.Address, Range("K767")).Value = Target.Value
    End If
    Application.EnableEvents = True
End Sub

mavi674 · Cumartesi saat 15:58'de

Muzaffer Ali
hocam bu ne hız...
İlgilendiğiniz için çok teşekkürler...
Yalnız ufak bir sorun var. Girdiğim sayıyı bütün alt satırlara kopyalanıyor.
Oysa sadece 24 satır ara ile (yeşil hücrelere) yazılmasını istemiştim.
Teşekkürler....

mavi674 · Cumartesi saat 16:04'de

Ayrıca yeşil hücreler duyarlı olması lazım.
yani yeşil hücrelerin haricinde girilen sayılar kopyalanmayacak.
Sadece yeşil hücreler çalışacak...
Teşekkürler...

Muzaffer Ali · Cumartesi saat 17:16'de

Bu kodu kullanın.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then
     'cancel = True
      If Target.Value <> 0 Then
          Target.Select
          sat = Target.Row
          
          If Cells(sat, 11) = "" Then
              Cells(sat, 11) = Target.Value
              'VİSA SIRA NO VERMEK İÇİN AŞAĞI SATIRI ÇALIŞTIR
              'Cells(sat - 1, 11) = 1
              
          ElseIf Cells(sat, Columns.Count) = Empty Then
                  sut = Cells(sat, Columns.Count).End(xlToLeft).Column
                  Cells(sat, sut + 1) = Target.Value
                  'VİSA SIRA NO VERMEK İÇİN AŞAĞI SATIRI ÇALIŞTIR
                  'Cells(sat - 1, sut + 1) = sut - 9
            End If
            Else
              'O GİRİNCE SİLMEK İÇİN
              sat = Target.Row
              sut = Cells(sat, Columns.Count).End(xlToLeft).Column
              Range(Cells(sat, 11), Cells(sat, sut)).ClearContents
              'ALT SATIR AKTİF OLURSA VİSANIN SIRA NOLARI SİLİNİR
              'Range(Cells(sat - 1, 11), Cells(sat - 1, sut)).ClearContents
    
     'Target.Select
     'If Target = 0 And Target <> "" Then
     'sat = Target.Row
     'sut = Cells(sat, Columns.Count).End(xlToLeft).Column
     'Range(Cells(sat, "L"), Cells(sat, "m")).ClearContents
        
      End If
      'sıfırlanınca imleç sabit durması için
      Target.Select
      'yazıldı
      Target.Value = ""
      
    ElseIf Not Intersect(Target, Range("K47:K767")) Is Nothing And Int((Target.Row - 23) / 24) = (Target.Row - 23) / 24 Then
        Target.Resize(24, 1).Value = Target.Value
    End If
    Application.EnableEvents = True
End Sub

mavi674 · Cumartesi saat 17:31'de

Hocam kod çalışmadı,
eksik birşey mi yaptım

Muzaffer Ali · Cumartesi saat 17:40'de

Dosya ekte.

mavi674 · Cumartesi saat 17:44'de

Selam
kod şöyle çalıştı.
Yeşil hücrelerden birisine giriş yaptığım zaman girış yaptığım hücrenin 23 satır altına kadar kopyalama yapıyor.
Oysa istediğim giriş yaptığım hücrenin altıdaki sadece yeşil hücrelere kopyalama yapması. (k767 hücreye kadar k767 dahil).

mavi674 · Cumartesi saat 17:46'de

Muzaffer Ali' Alıntı:
Dosya ekte.

şu anda altın üye değilim

Muzaffer Ali · Cumartesi saat 18:06'de

Dosyanızdaki kodları silip yerine aşağıdakini ekleyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then
     'cancel = True
      If Target.Value <> 0 Then
          Target.Select
          sat = Target.Row
          
          If Cells(sat, 11) = "" Then
              Cells(sat, 11) = Target.Value
              'VİSA SIRA NO VERMEK İÇİN AŞAĞI SATIRI ÇALIŞTIR
              'Cells(sat - 1, 11) = 1
              
          ElseIf Cells(sat, Columns.Count) = Empty Then
                  sut = Cells(sat, Columns.Count).End(xlToLeft).Column
                  Cells(sat, sut + 1) = Target.Value
                  'VİSA SIRA NO VERMEK İÇİN AŞAĞI SATIRI ÇALIŞTIR
                  'Cells(sat - 1, sut + 1) = sut - 9
            End If
            Else
              'O GİRİNCE SİLMEK İÇİN
              sat = Target.Row
              sut = Cells(sat, Columns.Count).End(xlToLeft).Column
              Range(Cells(sat, 11), Cells(sat, sut)).ClearContents
              'ALT SATIR AKTİF OLURSA VİSANIN SIRA NOLARI SİLİNİR
              'Range(Cells(sat - 1, 11), Cells(sat - 1, sut)).ClearContents
    
     'Target.Select
     'If Target = 0 And Target <> "" Then
     'sat = Target.Row
     'sut = Cells(sat, Columns.Count).End(xlToLeft).Column
     'Range(Cells(sat, "L"), Cells(sat, "m")).ClearContents
        
      End If
      'sıfırlanınca imleç sabit durması için
      Target.Select
      'yazıldı
      Target.Value = ""
      
    ElseIf Not Intersect(Target, Range("K47:K767")) Is Nothing And Int((Target.Row - 23) / 24) = (Target.Row - 23) / 24 Then
        Dim Bak As Long
        For Bak = Target.Row To 767 Step 24
            Cells(Bak, "K").Value = Target.Value
        Next
    End If
    Application.EnableEvents = True
End Sub

mavi674 · Cumartesi saat 18:20'de

Hocam tam hedeften vurdunnnnn
Süper olmuş tam istediğim gibi çalışıyor.
Eline sağlık, ellerin dert görmesin, iyki varsınız, sayenizde çok şeyler geliştirdik...
Çok sevindim, Teşekkürlerimi sunuyorum...

Muzaffer Ali · Cumartesi saat 18:32'de

Rica ederim. Kolay gelsin.

mavi674 · Pazartesi saat 16:33'de

Selam Hocam
Kodu baya kullandım, istediğim kod düzgün çalışıyor ama başka yerde sorun çıktı

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Local Error Resume Next
    If Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then Exit Sub
     'cancel = True
  
   Application.EnableEvents = False

istediğim kodu oluşturmak için 2. ve 5. satırı silmişsiniz DE sütununa çift tıklama yaptığımda

If Not Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then

hata veriyor

Muzaffer Ali · Pazartesi saat 17:15'de

mavi674' Alıntı:
Selam Hocam
Kodu baya kullandım, istediğim kod düzgün çalışıyor ama başka yerde sorun çıktı

Kod:

Private Sub Worksheet_Change(ByVal Target As Range) On Local Error Resume Next If Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then Exit Sub 'cancel = True Application.EnableEvents = False

istediğim kodu oluşturmak için 2. ve 5. satırı silmişsiniz DE sütununa çift tıklama yaptığımda

If Not Intersect(Target, [C1:C10000]) Is Nothing Or Target.Cells.Count > 1 Or Target.Value = "" Then

hata veriyor

Hatayı çözebilmem için hata mesajını da söylemelisiniz.
Dosyanızı eklerseniz daha kolay çözüm bulunabilir.

mavi674 · Pazartesi saat 19:04'de

Dosyayı ekledim Gerekli açıklamaları da yazdım.
Teşekkürler

İndir DENEME xls

Dosyayı indir DENEME xls

dosya.co

Muzaffer Ali · Pazartesi saat 19:20'de

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

Satırının bir altına aşağıdaki satırı ekleyin.

Kod:

If Target.Cells.Count > 1 Then Exit Sub

mavi674 · Pazartesi saat 19:40'de

yarın bakacağım teşekkürler

mavi674 · Pazartesi saat 21:40'de

Selam
yarını bekleyemedim eve geldim deneyeyim dedim
ama yüklediğim dosyayı indiremedim ???
Yarın denerim artık

mavi674 · Pazartesi saat 21:46'de

Selam
Muzaffer Ali hocam
Yazdığınız satırı ekledim, artık hata vermiyor...
Çok çok Teşekkürlerrrr

HÜCREYE GİRİLEN RAKAMI ALT SATIRLARA KOPYALAMAK

mavi674

İndir DENEME xls

Muzaffer Ali

Destek Ekibi

mavi674

mavi674

Muzaffer Ali

Destek Ekibi

mavi674

Muzaffer Ali

Destek Ekibi

Ekli dosyalar

mavi674

mavi674

Muzaffer Ali

Destek Ekibi

mavi674

Muzaffer Ali

Destek Ekibi

mavi674

Muzaffer Ali

Destek Ekibi

mavi674

İndir DENEME xls

Muzaffer Ali

Destek Ekibi

mavi674

mavi674

mavi674