• DİKKAT

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

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

M

mavi674

Katılım
2 Nisan 2008
Mesajlar
155
Excel Vers. ve Dili
2003 TÜRKÇE
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

Dosyayı indir DENEME
dosya.co
 
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
 
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....
 
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...
 
Son düzenleme:
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
 
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).
 
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
 
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...
 
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
 
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
Genişletmek için tıkla ...

Hatayı çözebilmem için hata mesajını da söylemelisiniz.
Dosyanızı eklerseniz daha kolay çözüm bulunabilir.
 
Dosyayı ekledim Gerekli açıklamaları da yazdım.
Teşekkürler


İndir DENEME

Dosyayı indir DENEME
dosya.co
 
Son düzenleme:
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
 
Selam
yarını bekleyemedim eve geldim deneyeyim dedim
ama yüklediğim dosyayı indiremedim ???
Yarın denerim artık
 
Selam
Muzaffer Ali hocam
Yazdığınız satırı ekledim, artık hata vermiyor...
Çok çok Teşekkürlerrrr
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst