كود ملف ترحيل واستعلام مع الشرح

[رؤوف1951]

بسم الله الرحمن الرحيم

إخزاني الأعزاء وبعد إذن أساتذتنا الكرام ...

قدمت بعضا مما فتح الله علينا به من علم أهداه لنا أساتذتنا في الأكواد من خلال الشرح البسيط في الرابطين التاليين

"أضع لكم بعض الاكواد البسيطة المطلوبة لتعم الفائدة "، " حماية الملف بالكود " 

وأخذا بنصيحة الأستاذ ياسر أبى البراء فأنا أقدم هنا ملف جديد سأذكر شروطه ومتطلباته فحاول أخي تنفيذ الملف بنفسك ثم سأضع الملف كاملا بين يديك ونتعلم فائدة كل سطر من الكود معا

بسم الله الرحمن الرحيم

طلب منى أحد أبنائي وهو دكتور أمراض نساء أن أعمل له ملف ينظم حركة المرضى بعيادته كالتالي:

- البيانات بالصورة كود- الاسم - الزوج- تاريخ الزواج- العمر- التليفون- العنوان- فصيلة الدم- تاريخ الزيارة

والمطلوب عمل شاشة افتتاحية لإدخال البيانات السابقة دون أن تتدخل الممرضة في بيانات الشيت ودون المساس ببنية لكود

سأترك أسبوع من الآن للمحاولة ثم سأنشر الكود وتفاصيل عمل الملف مع الشرح وهذا الملف سنستخدم فيه المعلومات التي تك شرحها في الموضوعين السابقين المشار إليهما

والله الموفق

[رؤوف1951]

السلام عليكم ورحمة الله وبركاته

لنبدأ بإنشاء الملف

حمل المرفق وحاول تنفيذ ما به وأي استفسار حاضرين إن شاء الله

Explaining.rar

[رؤوف1951]

السلام عليكم ورحمة الله وبركاته

والآن مع الكود 

في نافذة كود ThisWorkbook نكتب الكود

Private Sub WorkBook_Open()
Application.Visible = False
Range("A3:h10000").Sort Key1:=Range("B3:B10000"), Order1:=xlAscending, Header:=xlYes
User_Data.Show
End Sub

وفي نافذة كود كود User_Data نكتب الكود

Private Sub CommandButton1_Click()
Dim LRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Data")
LRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    If Trim(Me.TxtBox1.Value) = "" Then
        Me.TxtBox1.SetFocus
        MsgBox ("من فضلك أدخل الكود")
        Exit Sub
    End If
    If Trim(Me.TxtBox2.Value) = "" Then
        Me.TxtBox2.SetFocus
        MsgBox ("من فضلك أدخل الاسم")
        Exit Sub
    End If
ws.Cells(LRow, 1).Value = Me.TxtBox1.Value
ws.Cells(LRow, 2).Value = Me.TxtBox2.Value
ws.Cells(LRow, 3).Value = Me.TxtBox3.Value
ws.Cells(LRow, 4).Value = Me.TxtBox4.Value
ws.Cells(LRow, 5).Value = Me.TxtBox5.Value
ws.Cells(LRow, 6).Value = Me.TxtBox6.Value
ws.Cells(LRow, 7).Value = Me.TxtBox7.Value
ws.Cells(LRow, 8).Value = Me.TxtBox8.Value
ws.Cells(LRow, 9).Value = Me.TxtBox9.Value
Me.TxtBox1.Value = ""
Me.TxtBox2.Value = ""
Me.TxtBox3.Value = ""
Me.TxtBox4.Value = ""
Me.TxtBox5.Value = ""
Me.TxtBox6.Value = ""
Me.TxtBox7.Value = ""
Me.TxtBox8.Value = ""
Me.TxtBox9.Value = ""
Me.TxtBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
ActiveWorkbook.Close True
End Sub
Private Sub CommandButton3_Click()
Unload Me
User_Query.Show
End Sub
Private Sub CommandButton4_Click()
Unload Me
User_Password.Show
End Sub

Private Sub Label10_Click()

End Sub

Private Sub UserForm_QueryClose(cancel As Integer, closeMode As Integer)
If closeMode = 0 Then
cancel = True
MsgBox "عذرا الخروج من زر إغلاق"
End If
End Sub

وفي نافذة كود User_Password نكتب الكود

Private Sub Cmd_Sheet_Click()
If Txt_User_Name.Value = "roaa" And Txt_Password.Value = "123" Then
Application.Visible = True
Unload Me
Exit Sub
End If

MsgBox "المدخلات غير صحيحة - ادخل المطلوب مرة ثانية"
Txt_User_Name.Value = ""
Txt_Password.Value = ""
Txt_User_Name.SetFocus
End Sub

Private Sub CmdClose_Click()
Unload Me
ActiveWorkbook.Close True
End Sub
Private Sub UserForm_QueryClose(cancel As Integer, closeMode As Integer)
If closeMode = 0 Then
cancel = True
MsgBox "عذرا الخروج من زر إغلاق"
End If
End Sub

وفي نافذة كود User_qwery نكتب الكود

Private Sub ComboBox1_Change()
Set sh12 = Sheets("Data")
LR = sh12.[A10000].End(xlUp).Row
For Each cl In sh12.Range("A4:I" & LR)
If Me.ComboBox1 = cl Then
Me.TextBox1 = cl.Offset(0, -1)
Me.TextBox2 = cl.Offset(0, 0)
Me.TextBox3 = cl.Offset(0, 1)
Me.TextBox4 = cl.Offset(0, 2)
Me.TextBox5 = cl.Offset(0, 3)
Me.TextBox6 = cl.Offset(0, 4)
Me.TextBox7 = cl.Offset(0, 5)
Me.TextBox8 = cl.Offset(0, 6)
Me.TxtBox9 = cl.Offset(0, 7)
End If
Next
End Sub

Private Sub CommandButton1_Click()
Dim z As Integer
If Trim(TextBox2.Value) = "" Then
TextBox2.SetFocus
MsgBox ("من فضلك ادخل لاسم")
Exit Sub
End If
For z = 1 To 10000
If (TextBox2.Value) = Cells(z, 2) Then
Cells(z, 1) = TextBox1.Text
Cells(z, 3) = TextBox3.Text
Cells(z, 4) = TextBox4.Text
Cells(z, 5) = TextBox5.Text
Cells(z, 6) = TextBox6.Text
Cells(z, 7) = TextBox7.Text
Cells(z, 8) = TextBox8.Text
Cells(z, 9) = TxtBox9.Text
End If
Next
Unload Me
User_Query.Show
ComboBox1.SetFocus
End Sub

Private Sub CommandButton2_Click()
Unload Me
User_Data.Show
End Sub

Private Sub CommandButton3_Click()
Unload Me
ActiveWorkbook.Close True
End Sub

Private Sub UserForm_QueryClose(cancel As Integer, closeMode As Integer)
If closeMode = 0 Then
cancel = True
MsgBox "عذرا الخروج من زر إغلاق"
End If
End Sub

 

وهذا هو الملف كاملا

كلمة المرور للشيت "roaa" ، "123"

كملة المرور للكود "0"

Transport.rar

 

[mohammed_ali]

عمل مفيد مشكور وجزاكم الله خيراً  

[شعبان فليفل]

عمل رائع 

جزيت خيراً