Soru Koşullu Satır Kopyalama ve Silme

[Ankara55]

Merhaba;
Acil Yardım........ lütfen

SSH sayfasında A2'den A..... 'e kadar devam eden bilgilerin, M sütununda her hangi bir satıra "Hazır" yazdığımda ilgili bilgileri Sayfa2'ye sıra numarası 1 den başlayarak sıralı bir şekilde kopyalamasını ve sonra SSH sayfasındaki verinin silinmesini rica ediyorum
Bu sayfada on binlerce giriş var ve içinden çıkamaz hale geldim, yardımcı olabilirseniz çok sevinirim.

 

[Greenblacksea53]

Örnk dosyanızı yollarsanız yardımcı oluruz..

 

[Ankara55]

Kusura Bakmayın Yoğunluktan dosayayı eklememişim.

 

[YUSUF44]

Aşağıdaki kodları SSH sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırıp deneyin. İlk mesajınızda M sütunu demişsiniz ama dosya yapınızdan N sütununa Hazır yazacakmışsınız gibi anladım. Bu nedenle N sütununda Hazır yazınca çalışacak şekilde ayarladım. Yalnız büyük küçük harf duyarlıdır, sadece Hazır yazınca çalışır, önce veya sonra boşluk vs karakter olursa çalışmaz:

Private Sub Worksheet_Change(ByVal Target As Range)
son = Cells(Rows.Count, "C").End(3).Row
If Intersect(Target, Range("N2:N" & son)) Is Nothing Then Exit Sub
If Target = "Hazır" Then
    sor = MsgBox(Cells(Target.Row, "E") & " firmasının " & Chr(10) & _
          Format(Cells(Target.Row, "C"), "dd/mm/yyyy") & " tarihli," & Chr(10) & _
          Cells(Target.Row, "G") & " modeline ait " & Chr(10) & _
          Cells(Target.Row, "I") & " adet " & _
          Cells(Target.Row, "H") & Chr(10) & _
          " Parça siparişi diğer sayfaya aktarılacaktır." & Chr(10) & Chr(10) & _
          "Onaylıyor musunuz?", vbYesNo)
    If sor = vbYes Then
        Application.EnableEvents = False
            yeni = Sheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 1
            Rows(Target.Row).Copy: Sheets("Sayfa2").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
        Rows(Target.Row).Copy: Sheets("Sayfa2").Rows(yeni).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

            Sheets("Sayfa2").Cells(yeni, "A") = yeni
            Rows(Target.Row).Delete
        Application.EnableEvents = True
    End If
End If
End Sub

 

[Ankara55]

Gerçekten Çok Teşekkür Ederim. Elinize Emeğinize Sağlık. İstediğimden daha iyi olmuş. Hakkınızı Helal Edin.

 

[Ankara55]

Merhaba;
Tekrar aynı konu için rahatsız ediyorum.
SSH sayfası N sütununa "Hazır" yazdığım zaman açılan mesagebox a hayır dersem "Hazır" yazısı sabit kalıyor. Bir kaç kez alt alta hazır yazıp hayır dersem aşağıda kırmızı renk ile belirttiğim hatayı alıyorum.
Bir de her iki sayfanın A1 satırından başlayarak otomatik sıra numarası vermesini sağlayabilir miyiz?

 

[Ankara55]

SSH sayfası "M" sütunu olacaktı.

"Aldığım Hata Runtime-Error (13)"


Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Son
If Intersect(Target, Range("M2:M50000")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target = UCase(Replace(Replace(Target, "i", "İ"), "ı", "I"))
Son: Application.EnableEvents = True
Son = Cells(Rows.Count, "C").End(3).Row
If Intersect(Target, Range("M2:M" & Son)) Is Nothing Then Exit Sub
On Error Resume Next
If Target = "HAZIR" Then
sor = MsgBox(Cells(Target.Row, "E") & " Firmasının " & Chr(10) & _
Format(Cells(Target.Row, "C"), "dd/mm/yyyy") & " Tarihli," & Chr(10) & _
Cells(Target.Row, "G") & " Modeline Ait " & Chr(10) & _
Cells(Target.Row, "I") & " Adet " & _
Cells(Target.Row, "H") & Chr(10) & _
" Parça siparişi diğer sayfaya aktarılacaktır." & Chr(10) & Chr(10) & _
"ONAYLIYOR MUSUNUZ?", vbYesNo)
If sor = vbYes Then
Application.EnableEvents = False
yeni = Sheets("Hazırlanan_SSH").Cells(Rows.Count, "A").End(3).Row + 1
Rows(Target.Row).Copy: Sheets("Hazırlanan_SSH").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows(Target.Row).Copy: Sheets("Hazırlanan_SSH").Rows(yeni).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("Hazırlanan_SSH").Cells(yeni, "A") = yeni
Rows(Target.Row).Delete
Application.EnableEvents = True

End If
End If
End Sub

 

[YUSUF44]

Ben kodu aşağıdaki gibi kullanınca herhangi bir hata almadım. "Hayır" deyince hücrenin boş kalmasını sağlayacak şekilde kodu güncelledim.

Hata almadığım için sizdeki hatanın nedenini bilmiyorum ama kodda kullandığınız "On error" satırlarını mümkün oldukça kullanmamanızı tavsiye ederim. Çünkü o satırlar hataları görmenizi engeller, ortadan kaldırmaz, halının altına süpürür.,

Private Sub Worksheet_Change(ByVal Target As Range)
Son = Cells(Rows.Count, "C").End(3).Row
If Intersect(Target, Range("M2:M" & Son)) Is Nothing Then Exit Sub
Application.EnableEvents = False
    Target = UCase(Replace(Replace(Target, "i", "İ"), "ı", "I"))
Application.EnableEvents = True
If Target = "HAZIR" Then
    sor = MsgBox(Cells(Target.Row, "E") & " Firmasının " & Chr(10) & _
          Format(Cells(Target.Row, "C"), "dd/mm/yyyy") & " Tarihli," & Chr(10) & _
          Cells(Target.Row, "G") & " Modeline Ait " & Chr(10) & _
          Cells(Target.Row, "I") & " Adet " & _
          Cells(Target.Row, "H") & Chr(10) & _
          " Parça siparişi diğer sayfaya aktarılacaktır." & Chr(10) & Chr(10) & _
          "ONAYLIYOR MUSUNUZ?", vbYesNo)
    If sor = vbYes Then
        Application.EnableEvents = False
            yeni = Sheets("Hazırlanan_SSH").Cells(Rows.Count, "A").End(3).Row + 1
            Rows(Target.Row).Copy: Sheets("Hazırlanan_SSH").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
        Rows(Target.Row).Copy: Sheets("Hazırlanan_SSH").Rows(yeni).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

            Sheets("Hazırlanan_SSH").Cells(yeni, "A") = yeni
            Rows(Target.Row).Delete
        Application.EnableEvents = True
    Else
        Application.EnableEvents = False
            Target.ClearContents
        Application.EnableEvents = True
    End If
End If
End Sub

 

[Ankara55]

Tekrar teşekkür ederim. Sizi uğraştırıyorum kusura bakmayın.

 

[Ankara55]

Merhaba Ek'te bulunan dosyam ile ilgili yardıma ihtiyacım var. Gerekli açıklamaları dosya içerinde paylaştım.

 

[ÖmerFaruk]

Ürün Adını tıkladığınızda Useformddaki ListBox1 den ürün adını doğru çekebilmeniz için aşağıda dediğiklerimi uygulamanız yeterli olacaktır.

Userform1 kodlarınızdaki aşağıdaki satırları silin

Private Sub ListBox1_change()
ActiveCell.Value = ListBox1.Value
Cells(ActiveCell.Row, "D") = ActiveCell.Row - 1
End Sub

ListBox1 DblClick olayındakı kdolarınız aşağıdakiyle değiştirin.

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If ListBox1.ListIndex < 0 Then Exit Sub
    Cells(ActiveCell.Row, "D") = ListBox1.List(ListBox1.ListIndex, 0)
    Unload Me
End Sub

Sorunuzun diğer kısmı için DEPO sayfasına kayıtlarını ne zaman alacağınızı, nasıl bir işlem yapmak istediğinizi biraz daha tarif etmelisiniz.

 

[Ankara55]

Merhaba, yazdığınız kodu kopyaladıktan sonra userform da hangi hücrede ne seçersem seçeyim d sütunundaki aktif hücreye bilgi girişi yapıyor.

 

[Ankara55]

Sipariş Takip ve Depo sayfalarında yazmış olduğum notlara göre yardımcı olabilirseniz sevinirim

 

[ÖmerFaruk]

Merhaba, yazdığınız kodu kopyaladıktan sonra userform da hangi hücrede ne seçersem seçeyim d sütunundaki aktif hücreye bilgi girişi yapıyor.

Bu kısmı çözdünüz mü?
Ben son gönderdiğiniz dosyayı indirdim ama bir sorun göremedim.

 

[Ankara55]

Evet hallettim. Diğer sorunlarım kaldı.

 

[ÖmerFaruk]

Sorularınızı yapmaya çalışmadığınız tam anlamadım.

Satır eklerken kodlar hata vermesin istiyorsanız aşağıdaki ikinci satırı mevcut Change olayındaki kodlara ekleyiniz.

If Intersect(Target, Range("N3:N" & Son)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub