If Target.Count > 1 Then ise mevcut satırlar için kod çalışmaya devam etsin

[hsayar]

If Target.Count > 1 Then ise mevcut satırlar için kod çalışmaya devam etsin

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub                      'a4:a65536 aralığı değişmemişse çık
    If Target.Count > 1 Then Exit Sub
    
    If IsEmpty(Target) Then                                                         'değişen alan boşsa
        Range("B" & Target.Row & ":AB" & Target.Row).Select                         'B:AB aralığındaki satırları seç
        Selection.ClearContents                                                     'içeriğini boşalt
        Target.Select                                                               'değişen hücreyi seç
    Exit Sub: End If                                                                'prosodürden çık
..............

target.count>1 olması durumunda mevcut satırlar sıra ile Target.row a aktarılıp kodların çalışmasında işlerlik kazandırmak mümkün olurmu acaba?

 

[ceyrek]

Target olayı kafamda tam olarak oturmadığı için size şöyle bir çözüm sunayım:
bir adet command button ekleyin, silmek istediğiniz sütunları seçin ve butonu tıklayın

Private Sub CommandButton1_Click()
Range("B" & Selection.Row & ":AB" & Selection.Row + Selection.Rows.Count - 1).Select
Selection.ClearContents

End Sub

Umarı doğru anlamışımdır..

 

[hsayar]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub                      'a4:a65536 aralığı değişmemişse çık
    
    If Target.Count > 1 Then                                                        'birden fazla satır seçildiğinde
    Range("B" & Selection.Row & ":AB" & Selection.Row + Selection.Rows.Count - 1).Select  'b:ab aralığındaki seçili satırları seç ve sil
    Selection.ClearContents
    Exit Sub:    End If                                                              'makrodan ve konrolden çık
    
    If IsEmpty(Target) Then                                                         'değişen alan boşsa
        Range("B" & Target.Row & ":AB" & Target.Row).Select                         'B:AB aralığındaki satırları seç
        Selection.ClearContents                                                     'içeriğini boşalt
        Target.Select                                                               'değişen hücreyi seç
    Exit Sub:    End If                                                                'prosodürden çık
    
    'mükerrer kayıt kontolü

2 yaklaşık işlem 6 puan kazandınız.
Şaka bir yana kodlarınız güzel ama işimi tam anlamıyla görmüyor.
şöyleki Target yani a kolonunda değişen satır boş ise kodun dediğiniz gibi çalışması gerekiyor. örn:
a5 ve a10 seçili iken üzerinde deleteya basıldığında eylem gerçekleşecek,
ama ctrl + v ile değer yapıştırldığında
A5 dolu ise goto baglan
a6 boş ise b6:ab6 aralığını sil
a7 dolu ise goto baglan
a8 dolu ise goto baglan
a9 boş ise b9:ab9 aralığını sil
a10 boş ise b10:ab10 aralığını sil

 

[hsayar]

Kodların tamamını vereiyim ki daha sağlıklı olsun

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub                      'a4:a65536 aralığı değişmemişse çık
    
    If Target.Count > 1 Then                                                        'birden fazla satır seçildiğinde
    Range("B" & Selection.Row & ":AB" & Selection.Row + Selection.Rows.Count - 1).Select  'b:ab aralığındaki seçili satırları seç ve sil
    Selection.ClearContents
    Exit Sub:    End If                                                              'makrodan ve konrolden çık
    
    If IsEmpty(Target) Then                                                         'değişen alan boşsa
        Range("B" & Target.Row & ":AB" & Target.Row).Select                         'B:AB aralığındaki satırları seç
        Selection.ClearContents                                                     'içeriğini boşalt
        Target.Select                                                               'değişen hücreyi seç
    Exit Sub:    End If                                                                'prosodürden çık
    
    'mükerrer kayıt kontolü
    If Cells(Target.Row, "A") <> "" Then                                            'A s&#252;tununda de&#287;i&#351;en alan bo&#351; de&#287;ilse
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)                 's&#252;tundaki hedef de&#287;eri ta&#351;&#305;yan verileri say.
    If SAY > 1 Then                                                                 '1 den fazla ise
    Set BUL = Columns(Target.Column).Find(Target)                                   'de&#287;eri ta&#351;yan h&#252;creleri bul
    If Not BUL Is Nothing Then                                                      '?
    ADRES = BUL.Address                                                             '?
    Do                                                                              '?
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then                            '?
        SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))  '?
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)                                  '?
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES                          '?
    GoTo UYARI                                                                      'm&#252;kerrer kay&#305;t uyar&#305; ver alt makrosuna git
    End If: End If: End If
    GoTo Baglan                                                                     'm&#252;kerrer kay&#305;t yoksa ba&#287;lan alt makrosuna git
UYARI:
    ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & _
           Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")   'm&#252;kerrer kay&#305;t devam edecekmisiniz sorusunu sor?
    If ONAY = vbNo Then                                                                         'devam edilmeyecekse
        Range("b" & Target.Row & ":AB" & Target.Row).Select:        Selection.ClearContents     'b:ab aral&#305;&#287;&#305;n&#305; sil
        Target.Select:                                              Selection.ClearContents     'de&#287;i&#351;en h&#252;creyi se&#231; ve sil.
        Exit Sub                                                                                'makrodan &#231;&#305;k
    End If                                                                                      'kontrolden &#231;&#305;k
    '*****************************************************************
'Ripek - 26/12/2007
'veri taban&#305;na ba&#287;lan
Baglan:
Dim Baglanti As ADODB.Connection                                                    'ADODB ba&#287;lant&#305; de&#287;i&#351;keni tan&#305;mla
Dim Kayit1 As ADODB.Recordset                                                       'ADODB kay&#305;t alan de&#287;i&#351;keni tan&#305;mla
Dim FSO As Object                                                                   'Dosya kontol objesi tan&#305;mla
Dim SQLStr, Kaynak, tcno As String                                                  'Sorgulanacak alanlar, kaynak dosya, ve sorgulanacak kritere ili&#351;kin tan&#305;mlar&#305; yap
'***********************************************************************
currentrow = Target.Row                                                             '?
CurrentvALUE = Target.Value                                                         '?

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"                       'Kaynak olarak bu kitab&#305;n oldu&#287;u klas&#246;rde veri taban&#305; belirt
Set FSO = CreateObject("Scripting.FileSystemObject")                                'Dosya kontorol objesine de&#287;er ata
If FSO.FileExists(Kaynak) = False Then                                              'Kaynak dosya var m&#305; yokmu bak, yoksa
    MsgBox Kaynak & " " & " Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"                'Uyar&#305; ver,
    Exit Sub                                                                            'makrodan &#231;&#305;k
End If                                                                              'kontrolden &#231;&#305;k


tcno = Target.Value                                                                 'Sorgulanacak de&#287;eri ata
'Sorgulanacak ba&#351;l&#305;klar&#305; ve sorgulanacak kriteri yaz
basliklar = "TCK&#304;ML&#304;KNO, ADI, SOYADI, ANNEADI, BABAADI, DOGUMYER&#304;, DOGUMTAR&#304;H&#304;, "
basliklar = basliklar & "NFS_MHKY, NFS_ILCE, NFS_IL, "
basliklar = basliklar & "ADR_MUHTAR, ADR_ILCE, ADR_IL, ADR_CD_SKK, ADR_KNO, ADR_DNO "
sayfaadi = "[data$] "
sorgu = "TCK&#304;ML&#304;KNO = " & tcno
SQLStr = "SELECT " & basliklar & " FROM " & sayfaadi & " WHERE " & sorgu

Set Baglanti = CreateObject("ADODB.Connection")             'ba&#287;lant&#305;y&#305; kur
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak
        .CursorLocation = adUseServer
        .Mode = adModeReadWrite
        .Open
    End With

    If Err = 0 Then                                     'e&#287;er ba&#287;lant&#305;da hata yoksa
        Set Kayit1 = CreateObject("ADODB.Recordset")    'kay&#305;t ba&#287;lant&#305;s&#305;n&#305; kur
        With Kayit1
            .ActiveConnection = Baglanti
            .CursorLocation = adUseServer
            .CursorType = adOpenKeyset
            .LockType = adLockOptimistic
            .Source = SQLStr
            .Open
        End With
 '***********************************************************************

        If Kayit1.RecordCount = 1 Then                      '1 adet kay&#305;t bulundu ise
          Cells(currentrow, "B").Value = Kayit1("ADI")          'bulunanlar&#305; yaz
          Cells(currentrow, "C").Value = Kayit1("SOYADI")       '..   ""...
          Cells(currentrow, "D").Value = Kayit1("BABAADI")      '..   ""...
          Cells(currentrow, "E").Value = Kayit1("ANNEADI")      '..   ""...
          Cells(currentrow, "F").Value = Kayit1("DOGUMYER&#304;")    '..   ""...
          Cells(currentrow, "G").Value = Kayit1("DOGUMTAR&#304;H&#304;")  '..   ""...
          Cells(currentrow, "AA").Value = Kayit1("ADR_MUHTAR")  '..   ""...
          Cells(currentrow, "AB").Value = Kayit1("ADR_ILCE") & "/" & Kayit1("ADR_IL")   '..   ""...
          'Cells(currentrow, "AL").Value = Kayit1("NFS_MHKY")
          
          Range("h" & Target.Row).Select                        'h s&#252;tununu se&#231;
        Else
            MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"       'uyar&#305; ver
            tckno = CurrentvALUE
            UserForm1.Show                                                      'kay&#305;t eklemek i&#231;in user forma ge&#231;
        End If
    Else                                                        'ba&#287;lant&#305;da hata varsa
son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi" 'uayr&#305; ver
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close '?
Set Kayit1 = Nothing    'de&#287;i&#351;keni haf&#305;zadan sil
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close '?
Set Baglanti = Nothing  'de&#287;i&#351;keni haf&#305;zadan sil
Set FSO = Nothing       'de&#287;i&#351;keni haf&#305;zadan sil
End Sub

 

[hsayar]

ben birinci aşamayı halletim kaldı ikinci aşama siz değerli ustalarımın yardımı ile onuda halledebilirzi zannedersem kodalrda kırmızı satırda işaretledim.

Amacım a kolonunda tcnoları başka bir sayfada yapıştırıldığında dahi tcnoloarının sıra ile veritabanında aranıp karşılığını yazılmasıdır?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub                      'a4:a65536 aralığı değişmemişse çık
    
   
If Target.Count > 1 Then                                                        'birden fazla satır seçildiğinde

Dim Hcr As Range: Dim i%, y%: Dim arrStr()
'seçili satırları diziye al
For Each Hcr In ActiveWindow.Selection.Cells
    If Hcr.Column = 1 Then
        ReDim Preserve arrStr(y)
        arrStr(y) = Hcr.Row:        y = y + 1
        satirlar = Hcr.Row & vbCrLf & satirlar
    End If
Next
'seçili satırlar dizisini kontrol et
For i = 0 To UBound(arrStr)
    'boş olanlar için b:ab aralığını sil
    If Cells(arrStr(i), 1).Value = "" Then
        Cells(arrStr(i), 2).Select
        Range(Cells(arrStr(i), "b"), Cells(arrStr(i), "ab")).Select
        Selection.ClearContents
[B][color="RED"]    'dolu olanlar için mükerrer kayıt kontorlüne atla ama nasıl? [/color]  [/B]
'    ElseIf Cells(arrStr(i), 1).Value <> "" Then
'    GoTo YAZ
    End If
Next i
'Cells([a65536].End(3).Row, "a").Select
Cells(arrStr(0), "a").Select
Exit Sub:    End If                                                                'prosodürden çık
'*******/*/*/*/*/**/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*//*/*//*/*/*/*///**/*//*/*/*/**
YAZ:
    'mükerrer kayıt kontolü
    If Cells(Target.Row, "A") <> "" Then                                            'A sütununda değişen alan boş değilse
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)                 'sütundaki hedef değeri taşıyan verileri say.
    If SAY > 1 Then                                                                 '1 den fazla ise
    Set BUL = Columns(Target.Column).Find(Target)                                   'değeri taşyan hücreleri bul
    If Not BUL Is Nothing Then                                                      '?
    ADRES = BUL.Address                                                             '?
    Do                                                                              '?
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then                            '?
        SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))  '?
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)                                  '?
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES                          '?
    GoTo UYARI                                                                      'mükerrer kayıt uyarı ver alt makrosuna git
    End If: End If: End If
    GoTo Baglan                                                                     'mükerrer kayıt yoksa bağlan alt makrosuna git
UYARI:
    ONAY = MsgBox("Bu kayıt daha önce aşağıdaki satırlarda girilmiştir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & _
           Chr(10) & "İşleme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")   'mükerrer kayıt devam edecekmisiniz sorusunu sor?
    If ONAY = vbNo Then                                                                         'devam edilmeyecekse
        Range("b" & Target.Row & ":AB" & Target.Row).Select:        Selection.ClearContents     'b:ab aralığını sil
        Target.Select:                                              Selection.ClearContents     'değişen hücreyi seç ve sil.
        Exit Sub                                                                                'makrodan çık
    End If                                                                                      'kontrolden çık
    '*****************************************************************
'Ripek - 26/12/2007
'veri tabanına bağlan
Baglan:
Dim Baglanti As ADODB.Connection                                                    'ADODB bağlantı değişkeni tanımla
Dim Kayit1 As ADODB.Recordset                                                       'ADODB kayıt alan değişkeni tanımla
Dim FSO As Object                                                                   'Dosya kontol objesi tanımla
Dim SQLStr, Kaynak, tcno As String                                                  'Sorgulanacak alanlar, kaynak dosya, ve sorgulanacak kritere ilişkin tanımları yap
'***********************************************************************
currentrow = Target.Row                                                             '?
CurrentvALUE = Target.Value                                                         '?

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"                       'Kaynak olarak bu kitabın olduğu klasörde veri tabanı belirt
Set FSO = CreateObject("Scripting.FileSystemObject")                                'Dosya kontorol objesine değer ata
If FSO.FileExists(Kaynak) = False Then                                              'Kaynak dosya var mı yokmu bak, yoksa
    MsgBox Kaynak & " " & " Dosyası Bulunamadı.", vbInformation, "Bilgi"                'Uyarı ver,
    Exit Sub                                                                            'makrodan çık
End If                                                                              'kontrolden çık


tcno = Target.Value                                                                 'Sorgulanacak değeri ata
'Sorgulanacak başlıkları ve sorgulanacak kriteri yaz
basliklar = "TCKİMLİKNO, ADI, SOYADI, ANNEADI, BABAADI, DOGUMYERİ, DOGUMTARİHİ, "
basliklar = basliklar & "NFS_MHKY, NFS_ILCE, NFS_IL, "
basliklar = basliklar & "ADR_MUHTAR, ADR_ILCE, ADR_IL, ADR_CD_SKK, ADR_KNO, ADR_DNO "
sayfaadi = "[data$] "
sorgu = "TCKİMLİKNO = " & tcno
SQLStr = "SELECT " & basliklar & " FROM " & sayfaadi & " WHERE " & sorgu

Set Baglanti = CreateObject("ADODB.Connection")             'bağlantıyı kur
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak
        .CursorLocation = adUseServer
        .Mode = adModeReadWrite
        .Open
    End With

    If Err = 0 Then                                     'eğer bağlantıda hata yoksa
        Set Kayit1 = CreateObject("ADODB.Recordset")    'kayıt bağlantısını kur
        With Kayit1
            .ActiveConnection = Baglanti
            .CursorLocation = adUseServer
            .CursorType = adOpenKeyset
            .LockType = adLockOptimistic
            .Source = SQLStr
            .Open
        End With
 '***********************************************************************

        If Kayit1.RecordCount = 1 Then                      '1 adet kayıt bulundu ise
          Cells(currentrow, "B").Value = Kayit1("ADI")          'bulunanları yaz
          Cells(currentrow, "C").Value = Kayit1("SOYADI")       '..   ""...
          Cells(currentrow, "D").Value = Kayit1("BABAADI")      '..   ""...
          Cells(currentrow, "E").Value = Kayit1("ANNEADI")      '..   ""...
          Cells(currentrow, "F").Value = Kayit1("DOGUMYERİ")    '..   ""...
          Cells(currentrow, "G").Value = Kayit1("DOGUMTARİHİ")  '..   ""...
          Cells(currentrow, "AA").Value = Kayit1("ADR_MUHTAR")  '..   ""...
          Cells(currentrow, "AB").Value = Kayit1("ADR_ILCE") & "/" & Kayit1("ADR_IL")   '..   ""...
          'Cells(currentrow, "AL").Value = Kayit1("NFS_MHKY")
          
          Range("h" & Target.Row).Select                        'h sütununu seç
        Else
            MsgBox "Aradığınız Kayıt Bulunamadı.", vbInformation, "Bilgi"       'uyarı ver
            tckno = CurrentvALUE
            UserForm1.Show                                                      'kayıt eklemek için user forma geç
        End If
    Else                                                        'bağlantıda hata varsa
son:
    MsgBox "Bağlantı Hatası.Kontrol Ediniz", vbInformation, "Bilgi" 'uayrı ver
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close '?
Set Kayit1 = Nothing    'değişkeni hafızadan sil
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close '?
Set Baglanti = Nothing  'değişkeni hafızadan sil
Set FSO = Nothing       'değişkeni hafızadan sil
End Sub

 

[ceyrek]

Aşağıdaki şekilde yaparsanız, her satırı tek tek inceleme imkanını elde edersiniz, işleriniz daha az karmaşıklaşır bence.

Private Sub CommandButton1_Click()
For i = Selection.Row To Selection.Row + Selection.Rows.Count - 1
'Range("B" & Selection.Row & ":AB" & Selection.Row + Selection.Rows.Count - 1).Select
If Cells(i, 1).Value = "" Then
Range("B" & i, "AB" & i).Clear
Else
Call YAZ(i)
End If
Next
End Sub

Sub YAZ(ByVal i As Integer)
mükerrer kontrolünü burada yapın.
1. Burada If Cells(Target.Row, "A") <> "" Then  kontrol&#252;ne gerek yok, &#231;&#252;nk&#252; sadece As&#252;tunu dolu olan se&#231;iminizde bu kodlar &#231;al&#305;&#351;acak
2. i de&#287;i&#351;kenini burada kullanabilirsiniz, i&#351;lem yap&#305;lmakta olan sat&#305;r numaras&#305;d&#305;r.
End Sub

Umarım bu sefer doğru anlamışımdır

 

[hsayar]

hocam olaylar
Private Sub Worksheet_Change(ByVal Target As Range) olayında olduğu için beceremiyorum birazdan gene girişirim