• DİKKAT

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

Makro ile çift tıklama

igultekin2000

igultekin2000

Katılım
5 Eylül 2007
Mesajlar
1,247
Excel Vers. ve Dili
ofis 2010
iyi günler;
sürekli yaptığım işlemlerde, form' daki üstadlar sayesinde hazır kodlarla güzel çalışmalar yapıyorum. Sürekli yapılan işlemleri pratikleştirmek adına bir konun olup olmadığını öğrenmek istiyorum. Çeşitli aşamalardan sonra son hale gelen çalışmamda L2 hücresindeki bu 101 (başka kodda olabileceği için L2 hücresindeki değer) ile K4:K sütununda bu değer olduğunda , son dolu satırdaki değere kadar A:I satırının AKTAR sayfasına aktarılması silinsin veya silinmesin, aşağıda satıra geçmesi şeklinde. bu aşamaya gelen çalışmamda doublclik ile ilgili satırı çift tıklayarak AKTAR sayfasına aktarıyorum, yoğun olduğunda bu işlemi seriye bağlamak için, karışık anlatım oldu ama aşağıdaki makro başka işlemim de kullandığım, veri doğrulama yöntemi ile seri işlem yapmamı sağlıyor. Teşekkürler

Kod: 
Sub Tum()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim s1 As Worksheet
Dim s2 As Worksheet
Dim Firma As String
Dim i, say As Long

Set s1 = ThisWorkbook.Worksheets("CARI_HRK")
Set s2 = ThisWorkbook.Worksheets("listele")

say = s2.Cells(s2.Rows.Count, "b").End(3).Row

For i = 2 To say
 Firma = s2.Cells(i, "F").Value
If Firma <> "" Then
  
    s1.Cells(1, "b").Value = Firma
    Call aktarr
    Call SATIR_SIL
    Call detay_musteri
    Call tek_sayi_cevir
    Call ODENMEYENLER
    Call liste_biriktir

  
End If
Next i


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
veya
 

Ekli dosyalar

  • çift tıkla.jpg
    çift tıkla.jpg
    222.2 KB · Görüntüleme: 4
  • ÇİFT TIKLA.xlsm
    ÇİFT TIKLA.xlsm
    98.5 KB · Görüntüleme: 4
Biraz karışık oldu :)
L2 hücresine yazılan değeri K4:K'da arayacak ve aynı olan satırları diğer sayfaya taşıyacak doğru mu anladım.
 
Bil hayli karışık olmuş. :)
 
Sayfanın kod bölümüne yapıştırıp , deneyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [L2]) Is Nothing Then Exit Sub
    Dim c, sonsat
    On Error GoTo err
    sonsat = Sheets("AKTAR").Cells(Rows.Count, "A").End(3).Row + 1
    With Range(Range("K4"), Range("K" & Cells(Rows.Count, "K").End(3).Row))
        Set c = .Find(Target, LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                Sheets("AKTAR").Range(Sheets("AKTAR").Cells(sonsat, 1), Sheets("AKTAR").Cells(sonsat, 9)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 9)).Value
                sonsat = sonsat + 1
                Rows(c.Row).Delete Shift:=xlUp
                Set c = .Find(Target, LookIn:=xlValues)
           
            Loop While Not c Is Nothing
        End If
    End With
err:
End Sub
 

Ekli dosyalar

Son düzenleme:
EmrExcel16' Alıntı:
Sayfanın kod bölümüne yapıştırıp , deneyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [L2]) Is Nothing Then Exit Sub
    Dim c, sonsat
    On Error GoTo err
    sonsat = Sheets("AKTAR").Cells(Rows.Count, "A").End(3).Row + 1
    With Range(Range("K4"), Range("K" & Cells(Rows.Count, "K").End(3).Row))
        Set c = .Find(Target, LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                Sheets("AKTAR").Range(Sheets("AKTAR").Cells(sonsat, 1), Sheets("AKTAR").Cells(sonsat, 9)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 9)).Value
                sonsat = sonsat + 1
                Rows(c.Row).Delete Shift:=xlUp
                Set c = .Find(Target, LookIn:=xlValues)
          
            Loop While Not c Is Nothing
        End If
    End With
err:
End Sub
Genişletmek için tıkla ...
Teşekkür ederim makroda sorun yok, ama ben de ufak bir sorun var, L2 hücresine yazılan 101 elle manuel değişecek silem işlemi L2 hücresindeki değere göre olacak ancak makronun tetiklemesi için L2 değilde B2 hücresinin değişmesi şeklide revize mümkün olabilir mi? B2 hücresine sırayla fiş numaraları gelecek. Makro bu şekilde kullanabiliyorum, sadece değişen değerin B2' de olması işlemimi çok kolaylaştıracak, kusura bakmayın, bayağı rahatsız ettim.
 
"Kusurluk ve rahatsız verici bir durum yok ortada"

Koddaki L2 yazan yeri B2 olarak değiştirip dener misiniz ? istediğiniz bu şekilde mi?.
 
Yada B2 den seçim yapıp L2 değerine göre silme işlemi için de aşağıdaki kodlar ile yapılabilir.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
    Dim c, sonsat
    On Error GoTo err
    sonsat = Sheets("AKTAR").Cells(Rows.Count, "A").End(3).Row + 1
    With Range(Range("K4"), Range("K" & Cells(Rows.Count, "K").End(3).Row))
        Set c = .Find([L2], LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                Sheets("AKTAR").Range(Sheets("AKTAR").Cells(sonsat, 1), Sheets("AKTAR").Cells(sonsat, 9)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 9)).Value
                sonsat = sonsat + 1
                Rows(c.Row).Delete Shift:=xlUp
                Set c = .Find([L2], LookIn:=xlValues)
            
            Loop While Not c Is Nothing
        End If
    End With
err:
End Sub
 
EmrExcel16' Alıntı:
Yada B2 den seçim yapıp L2 değerine göre silme işlemi için de aşağıdaki kodlar ile yapılabilir.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
    Dim c, sonsat
    On Error GoTo err
    sonsat = Sheets("AKTAR").Cells(Rows.Count, "A").End(3).Row + 1
    With Range(Range("K4"), Range("K" & Cells(Rows.Count, "K").End(3).Row))
        Set c = .Find([L2], LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                Sheets("AKTAR").Range(Sheets("AKTAR").Cells(sonsat, 1), Sheets("AKTAR").Cells(sonsat, 9)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 9)).Value
                sonsat = sonsat + 1
                Rows(c.Row).Delete Shift:=xlUp
                Set c = .Find([L2], LookIn:=xlValues)
           
            Loop While Not c Is Nothing
        End If
    End With
err:
End Sub
Genişletmek için tıkla ...
şimdi tamam oldu, tekrar teşekkür eder, iyi çalışmalar dilerim. Elinize sağlık.
 
EmrExcel16' Alıntı:
Rica ederim , iyi çalışmalar.
Genişletmek için tıkla ...
İyi günler;
yeni farkettim ama çözemedim
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub

    Dim c, sonsat
    On Error GoTo err
    sonsat = Sheets("AKTAR").Cells(Rows.Count, "A").End(3).Row + 1
    With Range(Range("K4"), Range("K" & Cells(Rows.Count, "K").End(3).Row))
        Set c = .Find([L2], LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                Sheets("AKTAR").Range(Sheets("AKTAR").Cells(sonsat, 1), Sheets("AKTAR").Cells(sonsat, 11)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 11)).Value
                sonsat = sonsat + 1
                Rows(c.Row).Delete Shift:=xlUp
                Set c = .Find([L2], LookIn:=xlValues)
          
            Loop While Not c Is Nothing
        End If
    End With
err:
Call hspno_getir
Call SayiCevir_g
Call rapor_rapor1
Call senet
Call cek
Call b_senet
Call b_senet20
Call b_senet
End Sub
normal şartlarda 11 sütuna kadar silmesi gerekirken satır tamamen siliniyor, acaba bu kodla ilgili mi ? , değilse başka işlemlerimde sorun olabilir.
 
Evet kodla ilgili , koddaki Rows(c.Row).Delete Shift:=xlUp bu satırla ,sayfadaki değerin bulunduğu satırın tamamını sildirmişdik ama A:K arasını sildirmek istersek , koddaki o satırı bunun ile değiştirin Range("A" & c.Row & ":K" & c.Row).Delete Shift:=xlUp
 
Son düzenleme:
EmrExcel16' Alıntı:
Evet kodla ilgili , koddaki Rows(c.Row).Delete Shift:=xlUp bu satırla ,sayfadaki değerin bulunduğu satırın tamamını sildirmişdik ama A:K arasını sildirmek istersek , koddaki o satırı bunun ile değiştirin Range("A" & c.Row & ":K" & c.Row).Delete Shift:=xlUp
Genişletmek için tıkla ...
Teşekkürler, şimdi sorunsuz çalışıyor iyi çalışmalar.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst