Durum listesinden seçtiğim seçeneğe göre farklı sheete tüm satırı otomatik taşımak

[Tilkay]

Merhabalar,
Bir tablom var, bu tabloda projeler takip ediliyor, istediğim şey şöyle; ekteki tabloda da göreceğiniz gibi, durum kolonundaki seçeneklerden birini (Bitti, İptal)seçtiğimde tüm satırı otomatik olarak ilgili sheet'e taşımasını istiyorum. Taşıdıktan sonrada boş kalan satır silinmeli, taşıdığı sheettede bir öncekinin alt satırına taşımalı. Yardımlarınız için şimdiden teşekkür ederim. (Konuyla ilgili araştırma yaptım ama tam istediğim sonucu bulamadım)

 

[Orion1]

Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son
If Intersect(Target, Range("B2:B65536")) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
If Target.Value = "Bitti" Then
    sat = Sheets("Biten projeler").Cells(65536, "A").End(xlUp).Row + 1
    Sheets("Biten projeler").Cells(sat, "A").Value = Target.Offset(0, -1).Value
    Sheets("Biten projeler").Cells(sat, "B").Value = Target.Value
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "B")).Delete (xlUp)
End If
If Target.Value = "iptal" Then
    sat = Sheets("İptal projeler").Cells(65536, "A").End(xlUp).Row + 1
    Sheets("İptal projeler").Cells(sat, "A").Value = Target.Offset(0, -1).Value
    Sheets("İptal projeler").Cells(sat, "B").Value = Target.Value
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "B")).Delete (xlUp)
End If
son:
End Sub

 

[Tilkay]

Çok teşekkür ederim, tam istediğim gibi olmuş...
Peki bir şey daha sormak istiyorum... araya kolon eklediğim zaman kod da nasıl değişiklik yapmam gerek; mesela "projede sorumlu kişi" kolonu eklesem hem proje sheetine hemde biten, iptal proje sheetine... nasıl değişiklik yapmam gerek. Tşk...

 

[conari]

Bitti ve İptal, büyük küçük harf duyarlıdır.
11 sütun aktarılır.
B sütunu değerlendirildiğinden c ,d ,e -- K ya kadar eklemeler yapılabilir.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [B2:B10000]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
Set s1 = Sheets("Proje")
Set s2 = Sheets("Biten Projeler")
Set s3 = Sheets("İptal Projeler")
If Target.Value = "Bitti" Then
sat = s2.[b65536].End(3).Row + 1
sno = s1.Cells(Target.Row, "g").Value
s2.Range(s2.Cells(sat, 1), s2.Cells(sat, 11)).Value = s1.Range(s1.Cells(Target.Row, 1), s1.Cells(Target.Row, 11)).Value
Application.EnableEvents = False
Target.EntireRow.Delete Shift:=xlUp
Application.EnableEvents = True
Set s1 = Nothing
Set s2 = Nothing
Set s3 = Nothing
End If
If Target.Value = "İptal" Then
sat = s3.[b65536].End(3).Row + 1
sno = s1.Cells(Target.Row, "b").Value
s3.Range(s3.Cells(sat, 1), s3.Cells(sat, 11)).Value = s1.Range(s1.Cells(Target.Row, 1), s1.Cells(Target.Row, 11)).Value
Application.EnableEvents = False
Target.EntireRow.Delete Shift:=xlUp
Application.EnableEvents = True
Set s1 = Nothing
Set s2 = Nothing
Set s3 = Nothing
End If
End Sub

 

[Tilkay]

Sizede çok teşekkür ediyorum... Harika bir iş çıkardınız conari ve orion2, çok saolun...