veri aktarımı

[sbugraa]

Bir sayfada yazdığım verilerin diğer sayfaya işlenmesi ve silinerek yeni veri girişi için hazır olmasını, diğer sayfaya aktarılan verilerinde alt alta işlenmesini istiyorum yardımcı olursanız sevinirim. dosyayı ekte gönderiyorum.

 

[İhsan Tank]

Bir sayfada yazdığım verilerin diğer sayfaya işlenmesi ve silinerek yeni veri girişi için hazır olmasını, diğer sayfaya aktarılan verilerinde alt alta işlenmesini istiyorum yardımcı olursanız sevinirim. dosyayı ekte gönderiyorum.

Merhaba
Boş bir module kopyalayın ve deneyin

Option Explicit
Sub aktarım_61()
Dim ts, kaplan, trabzonspor
Set ts = Sheets("Gelen Evrak")
Set kaplan = Sheets("Evrak Listesi Gelen")
If ts.Range("H5") = Empty Then MsgBox "Tarih Boş", vbCritical, "Hata": _
ts.Range("H5").Select: Exit Sub
If ts.Range("H7") = Empty Then MsgBox "Sayı Boş", vbCritical, "Hata": _
ts.Range("H7").Select: Exit Sub
If ts.Range("H9") = Empty Then MsgBox "Havale Edilen Birim Boş", vbCritical, "Hata": _
ts.Range("H9").Select: Exit Sub
If ts.Range("H11") = Empty Then MsgBox "Havale Tarihi Boş", vbCritical, "Hata": _
ts.Range("H11").Select: Exit Sub
If ts.Range("H13") = Empty Then MsgBox "Konusu Boş", vbCritical, "Hata": _
ts.Range("H13").Select: Exit Sub
If ts.Range("H15") = Empty Then MsgBox "İçeriği Boş", vbCritical, "Hata": _
ts.Range("H15").Select: Exit Sub
If ts.Range("H17") = Empty Then MsgBox "Açıklamalar Boş", vbCritical, "Hata": _
ts.Range("H17").Select: Exit Sub
trabzonspor = MsgBox("Kaydı Yapıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
trabzonspor = kaplan.Range("C" & Rows.Count).End(xlUp).Row
kaplan.Range("C" & trabzonspor + 1) = ts.Range("H5")
kaplan.Range("D" & trabzonspor + 1) = ts.Range("H7")
kaplan.Range("E" & trabzonspor + 1) = ts.Range("H9")
kaplan.Range("F" & trabzonspor + 1) = ts.Range("H11")
kaplan.Range("G" & trabzonspor + 1) = ts.Range("H13")
kaplan.Range("H" & trabzonspor + 1) = ts.Range("H15")
kaplan.Range("I" & trabzonspor + 1) = ts.Range("H17")
kaplan.Range("B4") = 1
kaplan.Range("B4:B" & trabzonspor).DataSeries rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, step:=1, Trend:=False
ts.Range("H5") = Empty
ts.Range("H7") = Empty
ts.Range("H9") = Empty
ts.Range("H11") = Empty
ts.Range("H13") = Empty
ts.Range("H15") = Empty
ts.Range("H17") = Empty
MsgBox "Kayıt Tamamlandı", , "Bitiş"
ts.Range("G19") = WorksheetFunction.Max(kaplan.Range("B:B"))
End Sub

 

[sbugraa]

çok teşekkür ediyorum. tam istediğim gibi olmuş. sağolun

 

[İhsan Tank]

çok teşekkür ediyorum. tam istediğim gibi olmuş. sağolun

Rica ederim
:keyif: