• DİKKAT

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

Formülsüz=1

S

sensizsoldum

Katılım
10 Ekim 2010
Mesajlar
1,469
Excel Vers. ve Dili
2010 Türkçe
Merhaba
Günaydın, hayırlı sabahlar.
Formülsüz, a1 hücresine herhangi bir veri girildiğinde b1 hücresinde de 1 rakamı yazmasını sağlayabilmek mümkün müdür. Excelde bunu yapabilir miyiz?
Formülsüz olmasından kastım, çok fazla sayıda veri girişi var kasma olmaması için. Makroya da gelince diğer kodlarla çok anlaşmazlık oluyor o yüzden.
Teşekkür ederim şimdiden.
 
Merhaba,

Makro ile istediğinizi yapabilirsiniz.
 
Merhaba Korhan Bey,
Bunu ben makrolu olarak kullanıyorum elimde 2 farklı kod var ama ben 2den de memnun değilim
Bu kod:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then Exit Sub
If Target <> Empty Then
Cells(Target.Row, "G") = 1
Else
Cells(Target.Row, "G") = Empty
End If
ElseIf Target.Count > 1 Then
For A = Target.Row To Target.Row + Target.Count
If Cells(A, "A") <> Empty Then
Cells(A, "G") = 1
Else
Cells(A, "G") = Empty
End If: Next: End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Satır silerken çok fazla yavaşlama yapıyor, 1 satırı bile 5 sn. siliyor.


Bu kod ise sayfa da hangi hücreyi tıklasam işlem yapıyor, deli ediyor beni :)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Long
Satır = Cells(Rows.Count, 1).End(3).Row
If Satır < 3 Then Exit Sub
Range("G3:G" & Rows.Count) = ""
Range("G3:G" & Satır) = 1
End Sub
 
Merhaba,

Kontrol edebilmemiz için örnek dosya eklemelisiniz. Büyük ihtimalle kısır döngüye giren bölümler var. Bunu kontrol altına alırsanız sorun ortadan kalkar.
 
Merhaba Korhan Bey,
Şirkette olduğumdan dosya ekleyemiyorum üzgünüm. Akşama ekleyebilirim ancak.
İyi çalışmalar dilerim.
 
Merhaba Korhan Bey,
Örnek dosyayı ekledim ancak sayfa 1 deki kod işime daha çok yarıyor. Dediğim gibi ama tek bir satırı bile 5 sn. zamanda siliyor. Bunun olmasını hiç istemiyorum. Yüzlerce satırı silmeyi düşünemiyorum.
sayfa 2 deki kod ise hangi hücreyi tıklarsam işlem yapıyor. Şirkette kullandığım pc hayli yavaş olunca çok zorlanıyorum bu konuda. Bu yüzden bu kodu kullanmak istemiyorum.
Yardımlarınız için şimdiden gönülden teşekkürler.
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodu deneyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satir As Long
 
    If Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    If Target.Count = 1 Then
        If Target <> Empty Then
            Cells(Target.Row, "G") = 1
        Else
            Cells(Target.Row, "G") = Empty
        End If
    ElseIf Target.Count > 1 Then
        Satir = Cells(Rows.Count, 1).End(3).Row
        If Satir >= 3 Then
            With Range("G3:G" & Satir)
                .Formula = "=IF(A3="""","""",1)"
                .Value = .Value
            End With
        End If
    End If
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Merhaba Korhan Bey,
Yazdığınız kod gayet iyi güzel ama bir kaç minik sorunla karşılaşıyorum, makronun çalışmasına engel olacak. Mesela çoklu olarak A3:A10 arasına veri yapıştırıldığında ya da A3:F15 arasına veri yapıştırıldığında ve ya örneğin A3:A8 arasına manuel olarak veri girildiğinde ve yan hücreli B sütuna veri girildiğinde A sütundaki verileri sildiğimizde ve yeniden A3:A arasına veri girildiğinde de makro çalışmıyor. Bu makroyu düzenlemek yerine sizin kaleminizden bir makro yazılsa çok daha memnun olacağım.
A3:A ve A3:F arasına veri girildiğinde ister manuel, ister çoklu olarak yapıştırılsa da G3:G de 1 rakamın yazması. A3:A da veri yok ise karşısı olan G3:G de 1 rakamın olmaması gerekiyor. Umarım açıklayıcı anlatmışımdır.
İlgi ve alakalarınıza sonsuz teşekkür ederim. İyi çalışmalar dilerim.
Saygılarımla.

Osman
 
Merhaba,

Küçük bir detayı atlamışım. Üstteki mesajımdaki kodu güncelledim. Tekrar denermisiniz.
 
Merhaba Korhan Bey,
Çalışmamda kullanacağım şekilde her yöntemi denedim, kusursuz çalışıyor. Umarım sürpriz bir sorunla karşılaşmam. Her şey için teşekkür ederim, elinize bilginize sağlık. İyi çalışmalar dilerim.
Saygılarımla.
 
Merhaba Korhan Bey,
Bu kodu farklı sayfalara da uygulamam gerekiyor ama sayfada aynı başlıkla başlayan farklı kodlar da olunca kodlar çakışıyor. Başlık tek kalacak şekilde gereken uyarlamaları da yapıyorum ama kod işlem yapıyor. Yine bir hatalar yapıyorum of off :)


Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo son
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    Satır = Cells(Rows.Count, 1).End(3).Row
    Cells(Target.Row, 1) = Cells(Satır, 1)
    Cells(Target.Row, 3) = Cells(Satır, 3)
son:
End Sub





Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satir As Long
 
    If Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    If Target.Count = 1 Then
        If Target <> Empty Then
            Cells(Target.Row, "G") = 1
        Else
            Cells(Target.Row, "G") = Empty
        End If
    ElseIf Target.Count > 1 Then
        Satir = Cells(Rows.Count, 1).End(3).Row
        If Satir >= 3 Then
            With Range("G3:G" & Satir)
                .Formula = "=IF(A3="""","""",1)"
                .Value = .Value
            End With
        End If
    End If
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satir As Long, Adres As String, Nesne As Object, Alan As String
 
    On Error GoTo Son
 
    If Intersect(Target, Range("A3:B" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    If Target.Column = 1 Then
        If Target.Count = 1 Then
            If Target <> Empty Then
                Cells(Target.Row, "G") = 1
            Else
                Cells(Target.Row, "G") = Empty
            End If
        ElseIf Target.Count > 1 Then
            Satir = Cells(Rows.Count, 1).End(3).Row
            If Satir >= 3 Then
                With Range("G3:G" & Satir)
                    .Formula = "=IF(A3="""","""",1)"
                    .Value = .Value
                End With
            End If
        End If
    ElseIf Target.Column = 2 Then
        Satır = Cells(Rows.Count, 1).End(3).Row
        If Target.Count = 1 Then
            Cells(Target.Row, 1) = Cells(Satır, 1)
            Cells(Target.Row, 3) = Cells(Satır, 3)
        Else
            Adres = Selection.Address
            Set Nesne = CreateObject("VBScript.Regexp")
            Nesne.Pattern = "[^0-9\,\:\$]"
            Nesne.Global = True
            Alan = Nesne.Replace(Adres, "A")
            Range(Alan) = Cells(Satır, 1)
            Alan = Nesne.Replace(Adres, "C")
            Range(Alan) = Cells(Satır, 3)
            Alan = Nesne.Replace(Adres, "G")
            Range(Alan) = 1
            Set Nesne = Nothing
        End If
    End If
Son:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Merhaba Korhan Bey,
Kodu denedim g sütuna gelecek olan 1 rakamlar olan kod çalışmıyor. Diğer kod işlemi yapıyor.
 
Merhaba Korhan Bey,
Kodlarda minik bir değişiklik yaptım sütun ismi olarak belki kolaylık sağlayacaktır. Bu şekilde devam edebilirsek daha sağlıklı olacak kanaatindeyim. Güncel kodlar aşağıdaki gibidir.
Bilginize.




Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son
If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Satır = Cells(Rows.Count, 1).End(3).Row
Cells(Target.Row, 1) = Cells(Satır, 1)
Cells(Target.Row, 3) = Cells(Satır, 3)
son:
End Sub



'--------------------------------------


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Satir As Long

If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False

If Target.Count = 1 Then
If Target <> Empty Then
Cells(Target.Row, "G") = 1
Else
Cells(Target.Row, "G") = Empty
End If
ElseIf Target.Count > 1 Then
Satir = Cells(Rows.Count, 1).End(3).Row
If Satir >= 3 Then
With Range("G3:G" & Satir)
.Formula = "=IF(B3="""","""",1)"
.Value = .Value
End With
End If
End If

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
 
Merhaba Korhan Bey,
Rica etsem Konuya yeniden göz atabilirmisiniz.
Teşekkür ederim. İyi çalışmalar dilerim.
 
Merhaba,

Örnek dosyada önerdiğim kodu uygulayarak hangi işlemi yaptığınızda hangi bölümün olmadığını detaylıca yazarmısınız. Lütfen örnek dosyayıda ekleyin.
 
SAnırım iki makronun aynı anda Çalışmasını İstiyor birbirini bozmadan...
 
Merhaba Korhan Bey
Kodları birleştirme işlemini doğrudan yaptım. B3:B aralığına veri girişi yaptığımda A ve C sütundaki verilerde bir alt hücreye kopyalama işlemini yapıyor. B3:B aralığından veri sildiğimde karşısında ki E3:E den 1 rakamları silinmiyor. Daha sonra B3:B aralığına veri girdiğimde ise, ne A ve C sütundaki veri bir alt hücreye kopyalıyor ne de E3:E aralığına 1 rakamı geliyor. Sizden istirhamım B3:B aralığındaki veri silinip, yeniden girildiğinde de çalışması.
Örnek dosya ektedir.
İlgi ve alakanıza tekrardan Teşekkür ederim.
Mutlu akşamlar dilerim.



Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satir As Long
 
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    If Target.Count = 1 Then
        If Target <> Empty Then
            Cells(Target.Row, "E") = 1
        Else
            Cells(Target.Row, "E") = Empty
        End If
    ElseIf Target.Count > 1 Then
        Satir = Cells(Rows.Count, 1).End(3).Row
        If Satir >= 3 Then
            With Range("E3:E" & Satir)
                .Formula = "=IF(B3="""","""",1)"
                .Value = .Value
            End With
        End If
    End If
    
        On Error GoTo son
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    Satır = Cells(Rows.Count, 1).End(3).Row
    Cells(Target.Row, 1) = Cells(Satır, 1)
    Cells(Target.Row, 3) = Cells(Satır, 3)
son:
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satir As Long, Adres As String, Nesne As Object, Alan As String, Say As Long
 
    On Error GoTo Son
 
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    Adres = Selection.Address
    Set Nesne = CreateObject("VBScript.Regexp")
    Nesne.Pattern = "[^0-9\,\:\$]"
    Nesne.Global = True
    
    If Target.Cells.Count = 1 Then
        Satir = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        
        If Target = "" And Satir >= 3 Then
            Cells(Target.Row, "A") = ""
            Cells(Target.Row, "C") = ""
            Cells(Target.Row, "E") = ""
        ElseIf Target <> "" And Satir = 3 Then
            Cells(Target.Row, "E") = 1
        Else
            Cells(Target.Row, "A") = Cells(Satir, "A")
            Cells(Target.Row, "C") = Cells(Satir, "C")
            Cells(Target.Row, "E") = 1
        End If
    
    Else
        
        Alan = Nesne.Replace(Adres, "B")
        Say = WorksheetFunction.CountA(Range(Alan))
        
        If Say = 0 Then
            Alan = Nesne.Replace(Adres, "A")
            Range(Alan) = ""
            Alan = Nesne.Replace(Adres, "C")
            Range(Alan) = ""
            Alan = Nesne.Replace(Adres, "E")
            Range(Alan) = ""
        Else
            Satir = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If Satir >= 3 Then
                Alan = Nesne.Replace(Adres, "A")
                Range(Alan) = Cells(Satir, 1)
                Alan = Nesne.Replace(Adres, "C")
                Range(Alan) = Cells(Satir, 3)
            End If
            Alan = Nesne.Replace(Adres, "E")
            Range(Alan) = 1
        End If
        
    End If
        
Son:
    Set Nesne = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst