Sayfa Adına Göre Veri Aktarma

[akmes]

Merhaba,Bizim sirketimizde excelde sayfa sayfa firmaların bağlantı tonajları tutuluyor.Evrak girişi yapılırken haliyle sayfada firmanın ismi aranıyor tıklanıyor ve kayıt giriliyor.Sizden ricam bir menü yardımı ile ilgili sayfaya tarih sırasına göre veri aktarımı yapabilecek bir makcro varmıdır.Konu ile ilgili excel şablonumuz ektedir.İlginiz için şimdiden teşekkür ederim.

 

[Orion1]

Sizin için ekli dosyayı hazırladım.

Private Sub Image1_Click()
Dim sat As Long, sh As Worksheet
If Not IsDate(TextBox1.Text) Then
    MsgBox "Yanlış tarih girişi" & vbLf & "Kayıt Girilmedi", vbCritical, "UYARI"
    TextBox1.SetFocus
    Exit Sub
End If
If Not IsNumeric(TextBox6.Text) Then
    MsgBox "Yanlış sayı girişi" & vbLf & "Kayıt girilmedi.", vbCritical, "UYARI"
    TextBox6.SetFocus
    Exit Sub
End If
If Not IsNumeric(TextBox7.Text) Then
    MsgBox "Yanlış sayı girişi" & vbLf & "Kayıt girilmedi.", vbCritical, "UYARI"
    TextBox7.SetFocus
    Exit Sub
End If
If Not IsNumeric(TextBox8.Text) Then
    MsgBox "Yanlış sayı girişi" & vbLf & "Kayıt girilmedi.", vbCritical, "UYARI"
    TextBox8.SetFocus
    Exit Sub
End If
Set sh = Sheets(ComboBox1.Value)
sat = sh.Cells(65536, "A").End(xlUp).Row + 1
If sat >= 65533 Then
    MsgBox "Seçili sayfada satır doldu.Kayıt girilmedi.", vbCritical, "UYARI"
    Exit Sub
End If
sh.Cells(sat, "A").Value = CDate(TextBox1.Text)
sh.Cells(sat, "A").NumberFormat = "dd.mm.yyyy"
sh.Cells(sat, "B").Value = TextBox2.Text
sh.Cells(sat, "C").Value = TextBox3.Text
sh.Cells(sat, "D").Value = TextBox4.Text
sh.Cells(sat, "E").Value = TextBox5.Text
sh.Cells(sat, "F").Value = CDbl(TextBox6.Text)
sh.Cells(sat, "F").NumberFormat = "#,##0.00"
sh.Cells(sat, "G").Value = CDbl(TextBox7.Text)
sh.Cells(sat, "G").NumberFormat = "#,##0.00"
sh.Cells(sat, "H").Formula = "=F" & sat & "*G" & sat
sh.Cells(sat, "H").NumberFormat = "#,##0.00"
sh.Cells(sat, "I").Value = CDbl(TextBox8.Text)
sh.Cells(sat, "I").NumberFormat = "#,##0.00"
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = 0
TextBox7.Text = 0
TextBox8.Text = 0
TextBox2.SetFocus
MsgBox "Kayıt girildi." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

Private Sub Image2_Click()

End Sub

Private Sub Image2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image1.Visible = True
Image2.Visible = False
End Sub

Private Sub TextBox1_AfterUpdate()
TextBox1.Text = Format(TextBox1.Text, "dd.mm.yyyy")
End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub TextBox6_AfterUpdate()
TextBox6.Text = Format(TextBox6.Text, "#,##0.00")

End Sub

Private Sub TextBox6_Change()

End Sub

Private Sub TextBox7_AfterUpdate()
TextBox7.Text = Format(TextBox7.Text, "#,##0.00")
End Sub

Private Sub TextBox7_Change()

End Sub

Private Sub TextBox8_AfterUpdate()
TextBox8.Text = Format(TextBox8.Text, "#,##0.00")

End Sub

Private Sub TextBox8_Change()
End Sub

Private Sub TextBox8_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Dim i As Integer
For i = 2 To Worksheets.Count
    ComboBox1.AddItem Sheets(i).Name
Next
If ComboBox1.ListCount > 0 Then ComboBox1.ListIndex = 0
TextBox1.Text = Format(Date, "dd.mm.yyyy")
TextBox6.Text = 0
TextBox7.Text = 0
TextBox8.Text = 0
TextBox2.SetFocus
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image1.Visible = False
Image2.Visible = True
End Sub

 

[akmes]

Çok süper üstadım.Tam istediğim gibi bir de ödeme sütununuda ekleyebilirseniz benim için daha da iyi olacak.Eline kolunuza emeğinize sağlık..Saygılar.

 

[Orion1]

Çok süper üstadım.Tam istediğim gibi bir de ödeme sütununuda ekleyebilirseniz benim için daha da iyi olacak.Eline kolunuza emeğinize sağlık..Saygılar.

İstediğiniz eklemeyi yaptım.
Dosyayı 2 numaralı mesajdan indirebilirsiniz.

 

[akmes]

Allah razı olsun , teşekkür ederim.

 

[Orion1]

Allah razı olsun , teşekkür ederim.

Rica ederim.
İyi çalışmalar.

 

[mustafakoker]

Evren Bey Bende teşekkür ederim
bir form hazırlayacaktım kodlarınızı kullanabilirmiyim

 

[Orion1]

Evren Bey Bende teşekkür ederim
bir form hazırlayacaktım kodlarınızı kullanabilirmiyim

Kullanabilirsiniz.

 

[yanginci34]

evren arkadaş bende istesem ayıp olurmu acaba örnek aşağıda banada aynısını yaparsan iyi olur şimdiden teşekkürler...
Ekli dosyayı görüntüle EVRAK TAKİP.xls

 

[drykcktl]

İstediğiniz eklemeyi yaptım.
Dosyayı 2 numaralı mesajdan indirebilirsiniz.

http://www.excel.web.tr/f14/veri-ve-formul-aktarymy-t130480.html


banada yardım edermisiniz lütfen