اذهب الي المحتوي
أوفيسنا

مطلوب برنامج كامل يحتوي على فورم للطباعة و واخر لادخال البيانات

فلاح الجبوري
 مشاركة
إذهب إلى أفضل إجابة Solved by محمد هشام.,

الردود الموصى بها

فلاح الجبوري

فلاح الجبوري

قام بنشر
قام بنشر

السلام عليكم اخواني انا عضو جديد معكم

احتاج الى برنامج كامل يحتوي على فورم جاهز للطباعة و وفورم اخر لادخال البيانات 

  بحيث عندما اكتب الاسم في خانة البحث تظهر كافة معلوماته 

النطاق 500 موظف وبعثت مجموعة بيانات جديدة ممكن تشوفه لو تكرمت

اعرف ان طلبي كثير لكن املي بكم اكبر

 

فلاح.xlsx

رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر (معدل)

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

يصعب  الاشتغال على ملف فارغ لا يتضمن اي بيانات

  حاول اخي الكريم تصمييم  الفورم الخاص بك اولا مع اظافة بعض البيانات الوهمية على الملف  

1) مكان اظهار بيانات البحث هل على ليست بوكس او عناصر التيكست بوكس مثلا..........

2) توضيح البيانات المرغوب طباعتها مع تحديد النطاق 

لا يمكن الاشتغال على التخمين 

اين هو اخي اليوزرفورم الخاص بك ؟

تم تعديل بواسطه محمد هشام.
  • Like 2
رابط هذا التعليق
شارك
  • حسونة حسين changed the title to مطلوب برنامج كامل يحتوي على فورم للطباعة و واخر لادخال البيانات
فلاح الجبوري

فلاح الجبوري

قام بنشر
  • الكاتب
قام بنشر

كل عام وانتم بخير بمناسبة عيد الاضحى المبارك ارجو منكم مساعدتي في عملي محتاج الى واجهة ادخال كما هو موضح لكم الى 500 موظف 

New ورقة عمل Microsoft Excel.xlsm

رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر

جرب هل هدا ما تقصده  

Sub TEST()
Dim WS As Worksheet: Dim F As Worksheet
Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3")
 Application.ScreenUpdating = False
 F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _
 26).Value = Application.Index(WS.Range _
   ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _
        1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _
             14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26))
With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-3")
    End With
    Application.ScreenUpdating = True
    MsgBox "تم ترحيل البيانات بنجاح"
End Sub

 

New ورقة عمل Microsoft Excel 2.xlsm

  • Like 5
رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر (معدل)

هدا  ملف مغاير اخي الكريم 

على العموم  تفضل هده الاكواد الخاصة بك بعد تعديلها  

Private Sub CommandButton2_Click()
'بحث
    Dim WS As Worksheet, F As Worksheet, J As Long
    Dim rng As Range, LastRow As Long, Clé As String
    Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3]

    Application.ScreenUpdating = False
    If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub
    LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row
    
    Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _
          lookat:=xlWhole, SearchDirection:=xlPrevious)
If rng Is Nothing Then
    MsgBox " الاسم غير موجود", vbExclamation, Clé
 Else
  J = rng.Row
WS.[D5].Value = F.Cells(J, 2).Value:   WS.[D7].Value = F.Cells(J, 3).Value
WS.[D9].Value = F.Cells(J, 4).Value:   WS.[D11].Value = F.Cells(J, 5).Value
WS.[D13].Value = F.Cells(J, 6).Value:  WS.[D15].Value = F.Cells(J, 7).Value
WS.[D17].Value = F.Cells(J, 8).Value:  WS.[D19].Value = F.Cells(J, 9).Value
WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value
WS.[G7].Value = F.Cells(J, 12).Value:  WS.[G9].Value = F.Cells(J, 13).Value
WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value
WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value
WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value
WS.[G23].Value = F.Cells(J, 20).Value
  
  Application.ScreenUpdating = True
  End If
End Sub

اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة  

Private Sub CommandButton5_Click()
'تعديل
Dim WS As Worksheet, WS2 As Worksheet
Dim LastRow As Long, i As Long
Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1")
LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row
For i = 3 To LastRow
If WS.Range("B" & i).Value = WS2.[E3] Then
WS.Range("B" & i) = WS2.Range("D5")
WS.Range("C" & i) = WS2.Range("D7")
WS.Range("D" & i) = WS2.Range("D9")
WS.Range("E" & i) = WS2.Range("D11")
WS.Range("F" & i) = WS2.Range("D13")
'اتمم الكود
''''''''''''''''''''
''''''''''''''''''''


MsgBox "تم تعديل البيانات بنجاح"
   End If
 Next i
Application.ScreenUpdating = True
End Sub

 

 

 

 

123.xlsm

تم تعديل بواسطه محمد هشام.
تعديل الكود
  • Like 5
رابط هذا التعليق
شارك
  • أفضل إجابة
محمد هشام.

محمد هشام.

قام بنشر
  • أفضل إجابة
قام بنشر (معدل)

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة  

171893178216581.png

تم تعديل الكود ليسهل التعامل معه  

Private Sub CommandButton2_Click()
'بحث
    Dim WS As Worksheet, F As Worksheet
    Dim Irow As Long, Clé As String, i As Long
    Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3]

    Application.ScreenUpdating = False
    If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub
    Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row

Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _
                     lookat:=xlWhole, SearchDirection:=xlPrevious)

If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub
For i = 3 To Irow
If WS.Cells(i, 2) = Clé Then
' Colmun (D)
F.[D5] = WS.Cells(i, "B")
F.[D7] = WS.Cells(i, "C"):    F.[D9] = WS.Cells(i, "D"):    F.[D11] = WS.Cells(i, "E")
F.[D13] = WS.Cells(i, "F"):   F.[D15] = WS.Cells(i, "G"):  F.[D17] = WS.Cells(i, "H")
F.[D19] = WS.Cells(i, "I"):   F.[D21] = WS.Cells(i, "J"):  F.[D23] = WS.Cells(i, "K")
' Colmun (G)
F.[G7] = WS.Cells(i, "L"):    F.[G9] = WS.Cells(i, "M"):   F.[G11] = WS.Cells(i, "N")
F.[G13] = WS.Cells(i, "O"):   F.[G15] = WS.Cells(i, "P"):  F.[G17] = WS.Cells(i, "Q")
F.[G19] = WS.Cells(i, "R"):   F.[G21] = WS.Cells(i, "S"):  F.[G23] = WS.Cells(i, "T")
' Colmun (J)
F.[J7] = WS.Cells(i, "U")
F.[J9] = WS.Cells(i, "V"):   F.[J11] = WS.Cells(i, "W")
F.[J13] = WS.Cells(i, "X"):   F.[J15] = WS.Cells(i, "Y")
    End If
  Next
  Application.ScreenUpdating = True
End Sub

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

Private Sub CommandButton1_Click()
' اظافة
Dim WS As Worksheet: Dim F As Worksheet
Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2")
 Application.ScreenUpdating = False
 F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _
 24).Value = Application.Index(WS.Range _
   ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _
        1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _
             14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26))
With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-2")
    End With
    Lr = F.Range("A65500").End(xlUp).Row
    b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column
    F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin
    ' افراغ
CommandButton4_Click
Application.ScreenUpdating = True
    MsgBox "تم اضافة البيانات بنجاح"
End Sub

 

123 (1).xlsm

تم تعديل بواسطه محمد هشام.
  • Like 6
رابط هذا التعليق
شارك
  • 3 weeks later...
فلاح الجبوري

فلاح الجبوري

قام بنشر
  • الكاتب
قام بنشر

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

استاذ محمد اعرف اني ازعجك بطلباتي ولكنني اتعلم منك واتمنى المزيد 

اريد مساعدتك فيهذا الشين اريد البحث بالاسم الاول في خانة الاسماء ان تكرمت علي اكون ممنون منك جدا

علما ان الشيت 1000 اسم

فكرة مشروع.xlsx

رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر

 

5 ساعات مضت, فلاح الجبوري said:

البحث بالاسم الاول في خانة الاسماء

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

 

  • Like 3
رابط هذا التعليق
شارك
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept