Satırları Kes ve Aktar

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar; aşağıdaki kodla LİSTE Sayfamdaki satırlardaki personeli A ile AG arasındaki verileri siliyor.

Sub KesVeAktar()
Set ar = Sheets("LİSTE")
    Satır = Application.InputBox("Silmek istediğiniz Personelin SİCİLİNİ yazın.", "PERSONEL SİLME VE AKTARMA", 1, 1)
    If Satır = False Then Exit Sub
    If Satır = False Then
        MsgBox "Silme İşleminden vazgeçildi..", vbInformation, "..:: HACI ::..": Exit Sub
    End If
    If WorksheetFunction.CountIf(Sheets("LİSTE").[B:B], 0 + Satır) > 0 Then
        sat = WorksheetFunction.Match(0 + Satır, ar.[B:B], 0)
        ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).[COLOR="Red"]Delete [/COLOR]Shift:=xlUp
        
        MsgBox Satır & " SİCİL Numaralı Personel bilgileri aktarıldı...", vbInformation, "..:: HACI ::.."
    Else
        MsgBox "Yazdığınız SİCİL bulunamadı!..."
    End If
End Sub

Ben burda bu verileri silmeyerek yani keserek (CUT) aynı dosyanın TÜM sayfasına 2. satırdan başlamak üzere alt alta eklemek istiyorum, yani personel LİSTE sayfasından çıkartılıp, TÜM sayfasına aktarılacak.
Yardımcı olacak herkese teşekkürler.

 

[dEdE]

Merhaba,

        sat = WorksheetFunction.Match(0 + Satır, ar.[B:B], 0)

satırından sonra gelmek üzere aşağıdaki satırları ekleyerek dener misiniz?

ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)

 

[Hacı Bayram ÖZKAN]

Sayın dede çok teşekkür ederim. Eline sağlık dua ile kal. Birde ricam daha olacaktı. Kusura bakmayın unuttum. Aktarılan personelin "S" Sütununda personelin AYRILIŞ TARİHİ var, bir mesajla aktarılan personelin "AKTARILAN PERSONELİN AYRILIŞ TARİHİNİ GİRİNİZ" deyip, bu tarihi aynı formatta yine TÜM sayfasının "S" sütununa kayıt etmesi için nasıl bir ek kod yazılır. Teşekkürler.

 

[dEdE]

... Aktarılan personelin "S" Sütununda personelin AYRILIŞ TARİHİ var, bir mesajla aktarılan personelin "AKTARILAN PERSONELİN AYRILIŞ TARİHİNİ GİRİNİZ" deyip, bu tarihi aynı formatta yine TÜM sayfasının "S" sütununa kayıt etmesi...

"S" sütununda ayrılış tarihi varsa, buradan aktarılabilir. Ayrıca tarih girilmesini anlayamadım.

 

[Hacı Bayram ÖZKAN]

Abi şöyle; LİSTE sayfasında normalde ayrılış tarihi yok, ancak personel ayrılınca tüm sayfada AYRILIŞ tarihi olacak burada amaç liste sayfasında ayrılan personelin hangi tarihte ayrıldığını daha sonra görmek örnek dosya ekliyorum. Biz normalde İŞE BAŞLAMA TARİHİ yazılıyor ayrılınca AYRILIŞ TARİHİ OLACAK ama buda TÜM Sayfasında olacak. Yani aktarırken soracak ve O personelin satırına yazacak.
Kısaca kod çalıştığında; Personelin sicilini giriniz. Bu belirlendikten sonra Aktarma işlemini yaparken, Yine mesajla ayrılış tarihini soracak, bu tarihte personelin TÜM sayfasındaki bilgilerine kayıt edecek. Teşekkürler.

 

[dEdE]

Merhaba,

     sat = WorksheetFunction.Match(0 + Satır, ar.[B:B], 0)

satırından sonra gelmek üzere aşağıdaki satırları ekleyip dener misiniz?

A_Tarih = Application.InputBox("Lütfen Ayrılış Tarihini Yazınız.   ", "A TARİHİ TARİHİ")
If A_Tarih = False Then Exit Sub
ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)
Sheets("Tüm").Range("S" & ss) = A_Tarih

 

[Hacı Bayram ÖZKAN]

If A_Tarih = False Then GoTo exit sub

Abim, Burası kırmızı yandı. Goto seçeneğini kaldırınca yaptı ama personeli iki kere yazdı yani aynı personeli iki kere aktarıyor.

 

[dEdE]

Haklısınız. "GoTo " ifadesi olmayacak. Yukarıdaki mesajda düzelttim.

 

[dEdE]

Aşağıdaki kodu dener misiniz?

Sub KesVeAktar()
Set ar = Sheets("LİSTE")
    Satır = Application.InputBox("Silmek istediğiniz Personelin SİCİLİNİ yazın.", "PERSONEL SİLME VE AKTARMA", 1, 1)
    If Satır = False Then Exit Sub
    If Satır = False Then
        MsgBox "Silme İşleminden vazgeçildi..", vbInformation, "..:: HACI ::..": Exit Sub
    End If
    If WorksheetFunction.CountIf(Sheets("LİSTE").[B:B], 0 + Satır) > 0 Then
        sat = WorksheetFunction.Match(0 + Satır, ar.[B:B], 0)
'------------------------------------------------
    A_Tarih = Application.InputBox("Lütfen Ayrılış Tarihini Yazınız.   ", "A TARİHİ TARİHİ")
    If A_Tarih = False Then GoTo Son
        ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
        ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)
        Sheets("Tüm").Range("S" & ss) = A_Tarih
'------------------------------------------------
        ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Delete Shift:=xlUp
        MsgBox Satır & " SİCİL Numaralı Personel bilgileri aktarıldı...", vbInformation, "..:: HACI ::.."
    Else
        MsgBox "Yazdığınız SİCİL bulunamadı!..."
    End If
Son:
End Sub

 

[Hacı Bayram ÖZKAN]

Tamam abi şimdi oldu zahmet verdim eline sağlık dua ile kal

 

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar Sayın Dedenin hazırlamış olduğu, kodla (9 Nolu mesaj) verileri Tüm sayfasına keserek aktarıyor. Ancak ben buna bir ilave dava yaptım.

'------------------------------------------------
A_Tarih = Application.InputBox("Lütfen Ayrılış Tarihini Yazınız. ", "A TARİHİ TARİHİ")
If A_Tarih = False Then GoTo Son
ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)
Sheets("Tüm").Range("S" & ss) = A_Tarih
'------------------------------------------------
yani bu kodu ekledim. Aşağıda

'------------------------------------------------
Gittiği_İl = Application.InputBox("Lütfen Gittiği İli Yazınız. ", "ATAMA YERİ", "OSMANİYE")

If Gittiği_İl = False Then GoTo son
ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)
Sheets("Tüm").Range("X" & ss) = Gittiği_İl
'------------------------------------------------
Personelin gittiği ili TÜM sayfasının X sütununa yazdırmak istiyorum. Ama işlem sonucu iki satır aktarıyor, ve 1. satırın İşten ayrılış tarihi doğru, ancak Gittiği ili yazmıyor. bunu ise 2 satıra yazıyor. Bunu nasıl düzeltirim. Kodun tamamı aşağıda.

Sub KesVeAktar()
Set ar = Sheets("LİSTE")
Satır = Application.InputBox("Aktarmak istediğiniz Personelin SİCİLİNİ yazın.", "PERSONELİ TÜM SAYFASINA AKTARMA", 165637, 1)
If Satır = False Then Exit Sub
If Satır = False Then
MsgBox "Aktarma İşleminden vazgeçildi..", vbInformation, "..:: HACI ::..": Exit Sub
End If
If WorksheetFunction.CountIf(Sheets("LİSTE").[B:B], 0 + Satır) > 0 Then
sat = WorksheetFunction.Match(0 + Satır, ar.[B:B], 0)
'------------------------------------------------
A_Tarih = Application.InputBox("Lütfen Ayrılış Tarihini Yazınız. ", "AYRILIŞ TARİHİ", "02.01.2021")

If A_Tarih = False Then GoTo son
ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)
Sheets("Tüm").Range("S" & ss) = A_Tarih
'------------------------------------------------
Gittiği_İl = Application.InputBox("Lütfen Gittiği İli Yazınız. ", "ATAMA YERİ", "OSMANİYE")

If Gittiği_İl = False Then GoTo son
ss = Sheets("Tüm").Cells(Rows.Count, 2).End(3).Row + 1
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Copy Sheets("Tüm").Range("A" & ss)
Sheets("Tüm").Range("X" & ss) = Gittiği_İl
'------------------------------------------------
ar.Range(ar.Cells(sat, "A"), ar.Cells(sat, "AG")).Delete Shift:=xlUp
MsgBox Satır & " SİCİL Numaralı Personel bilgileri aktarıldı...", vbInformation, "..:: HACI ::.."
Else
MsgBox "Yazdığınız SİCİL bulunamadı!..."
End If

son:
End Sub