أكاديمية الصقر للتدريب

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


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





كود ترحيل لمطعم

السلام عليكم ورحمة الله اخوانى الاعزاء فى المرفقات شيت اكسيل به المطلوب وبما ان هناك اكثر من زر او اصناف كثيرة يتم تط ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


subject icon تمت الإجابة كود ترحيل لمطعم
13-12-2020 07:06 مساء
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 

السلام عليكم ورحمة الله 
اخوانى الاعزاء
فى المرفقات شيت اكسيل 
به المطلوب 
وبما ان هناك اكثر من زر او اصناف كثيرة يتم تطبيق المطلوب عليها

ف المطلوب هو التطبيق على صنف واحد داخل الفورم وانا ساقوم بالتكرار بنفس النمط على باقى الاكواد

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

وجزاكم الله عنا كل خير
.... مشاركة مكررة , تم بالفعل حذف المشاركة الأخرى
 
 
  اصناف المطعم2.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(614.958) KB



أفضل إجابة مقدمة من salim وهي:
تم التعديل على الكود كما تريد

Dim my_sheet As Worksheet
Dim Sh As Worksheet
Dim Ro_sh%, i%, Final_Ro
Dim Rg As Range
Dim Find_what As Range
Dim Bt, t%
Dim rg_Itm As Range

'++++++++++++++++++++++++++++
Sub Debut()
  Set my_sheet = Sheets("ثوابت")
  Set Sh = Sheets("مبيعات")
   Ro = my_sheet.Cells(Rows.Count, 1).End(3).Row
   Ro_sh = Sh.Cells(Rows.Count, 2).End(3).Row + 1
  Set Rg = my_sheet.Range("a3:a" & Ro)
  Set Bt = UserForm1.ActiveControl
End Sub
'++++++++++++++++++++++++++++++++
Private Sub UserForm_Click()
  With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  End With

Debut
 If TypeName(Bt) <> "CommandButton" Then GoTo Bay_Bay
 If Bt.Caption Like "*صنف*" Then
       Me.T_date = ""
      For i = 2 To 5
        Me.Controls("T_" & i) = vbNullString
      Next

 Set Find_what = Rg.Find(Bt.Caption, lookat:=1)
 If Not Find_what Is Nothing Then
      
        Me.T_date = Format(Date, "[$-ar-Lb] ddd d mmm yy")
      For i = 2 To 5
          Select Case i
            Case 2: st = "  بيع: "
            Case 3: st = "  تكلفة: "
            Case 4: st = "  الوزن: "
            Case 5: st = "  التصنيف: "
          End Select
             Me.Controls("T_" & i) = _
             st & my_sheet.Cells(Find_what.Row, i)
      Next
      Set rg_Itm = Sh.Cells(5, "D").Resize(Ro_sh + 1).Find(Bt.Caption, lookat:=1)
       If Not rg_Itm Is Nothing Then
         t = rg_Itm.Row
         If Sh.Cells(t, 2) = Format(Date, "[$-ar-lb] ddd d mmm yy") Then
          Sh.Cells(t, "E") = Val(Sh.Cells(t, "E")) + 1
         End If
        
       Else
         With Sh.Cells(Ro_sh, 2)
         .Value = Format(Date, "[$-ar-lb] ddd d mmm yy")
         .Offset(, 2) = Bt.Caption
         .Offset(, 3) = 1
         .Offset(, 4) = my_sheet.Cells(Find_what.Row, 2)
         .Offset(, 5) = my_sheet.Cells(Find_what.Row, 3)
         .Offset(, 8) = my_sheet.Cells(Find_what.Row, 4)
         .Offset(, 9) = my_sheet.Cells(Find_what.Row, 5)
        End With
         
        End If 'rg_Itm isnothing
   Else
      GoTo Bay_Bay
  End If
 End If

 Final_Ro = Sh.Cells(Rows.Count, 2).End(3).Row
 If Final_Ro > 5 Then
   Sh.Range("H6:H" & Final_Ro).Formula = _
    "=IF(OR(E6="""",F6=""""),"""",PRODUCT(E6,F6))"
   Sh.Range("I6:I" & Final_Ro).Formula = _
    "=IF(OR(E6="""",G6=""""),"""",PRODUCT(E6,G6))"
'    Sh.Range("A6:A" & Final_Ro).Formula = _
' "=SUMPRODUCT(--(B6&D6=$B$6:$B6&$D$6:$D6)) &"" (""&D6&"" لهذا اليوم  )"""
  With Sh.Range("B6:K" & Final_Ro)
     .HorizontalAlignment = 1
     .InsertIndent 1
     .Borders.LineStyle = 1
     .Font.Size = 14
     .Font.Bold = True
  End With
 End If
Bay_Bay:
 With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With
End Sub

الملف مرفق
عرض الإجابة




14-12-2020 01:56 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود ترحيل لمطعم
هذا الكود بالنسبة للصنف1

Dim my_sheet As Worksheet
Dim Ro%, i%
Dim Rg As Range
Dim Find_what As Range
Sub Debut()
  Set my_sheet = Sheets("ثوابت")
  Ro = my_sheet.Cells(Rows.Count, 1).End(3).Row
  Set Rg = my_sheet.Range("a3:a" & Ro)

End Sub
Private Sub CommandButton1_Click() 'Sinf1
 Debut
Dim st$
 Me.T_date = ""
 
  For i = 2 To 5
    Me.Controls("T_" & i) = vbNullString
   Next
 Set Find_what = Rg.Find(Me.CommandButton1.Caption, lookat:=1)
 If Not Find_what Is Nothing Then
  Me.T_date = Format(Date, "[$-ar-Lb] ddd d mmm yy")
 For i = 2 To 5
 Select Case i
   Case 2: st = "  بيع: "
   Case 3: st = "  تكلفة: "
   Case 4: st = "  الوزن: "
   Case 5: st = "  التصنيف: "
 End Select
    Me.Controls("T_" & i) = _
    st & my_sheet.Cells(Find_what.Row, i)
 Next
 End If
End Sub

 
 
 
  Asnaf_User.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(592.092) KB


14-12-2020 05:08 مساء
مشاهدة مشاركة منفردة [2]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود ترحيل لمطعم
هذا الكود يمكنه تشغيل كل الأزار التي تحتوي على كلمة "صنف"
1- اضغط الزر المناسب(يحتوي على كلمة "صنف")
2- اضغط في اي مكان على اليوزر (المنطقة الحمراء)
3- تنتقل المعلومات من الشيت (ثوابت) الى التكست بوكس المناسب

Dim my_sheet As Worksheet
Dim Ro%, i%
Dim Rg As Range
Dim Find_what As Range
Dim Bt
'++++++++++++++++++++++++++++
Sub Debut()
  Set my_sheet = Sheets("ثوابت")
  Ro = my_sheet.Cells(Rows.Count, 1).End(3).Row
  Set Rg = my_sheet.Range("a3:a" & Ro)
  Set Bt = UserForm1.ActiveControl
End Sub
'++++++++++++++++++++++++++++++++
Private Sub UserForm_Click()
Debut
 If Bt.Caption Like "*صنف*" Then
 Me.T_date = ""
    For i = 2 To 5
      Me.Controls("T_" & i) = vbNullString
    Next
'++++++++++++++++++++++++++++++
 Set Find_what = Rg.Find(Bt.Caption, lookat:=1)
 If Not Find_what Is Nothing Then
  Me.T_date = Format(Date, "[$-ar-Lb] ddd d mmm yy")
 For i = 2 To 5
 Select Case i
   Case 2: st = "  بيع: "
   Case 3: st = "  تكلفة: "
   Case 4: st = "  الوزن: "
   Case 5: st = "  التصنيف: "
 End Select
    Me.Controls("T_" & i) = _
    st & my_sheet.Cells(Find_what.Row, i)
 Next
 End If
 End If
End Sub

الملف مرفق
 
 
  Asnaf_User_Full.xlsm   تحميل xlsm مرات التحميل :(12)
الحجم :(594.698) KB


16-12-2020 12:03 صباحا
مشاهدة مشاركة منفردة [3]
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 
look/images/icons/i1.gif كود ترحيل لمطعم
السلام عليكم ورحمة الله وبركاتة 
جزااااااااااااااااااااااك الله عنا كل خير 
وفيت المطلوب استاذنا الافاضل بالنسبة للمطلب الاول
بالنسبة لجميع الازرار الله يبارك لك فى ذلك بل وافضل مما طلبت
ولكن بعد الضغط على الزر لا يتم ترحيل هذه البيانات الى شيت المبيعات ومع كل ضغطة لنفس الصنف يتم زيادة العدد لنفس الصنف 

16-12-2020 01:30 مساء
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود ترحيل لمطعم
بعد الضغط على الزر لا يتم ترحيل هذه البيانات الى شيت المبيعات
أنت لم تطلب ذلك في سؤالك
بل قلت ان تنتقل المعلومات الى التكست بوكسات

16-12-2020 05:42 مساء
مشاهدة مشاركة منفردة [5]
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 
look/images/icons/i1.gif كود ترحيل لمطعم
الف شكر لسعه صدرك ومتابعه الموضوع 
ربنا يجعلة ف ميزان حسناتك يارب
هو اه حضرتك المطلوب مش مكتوب ف الموضوع لكنه مكتوب فى شيت الاكسل 
مشكلتى انى مش عايز انى لما ادوس ع الزر يتم ترحيل عدد جديد بسطر جديد ف كل مرة
انا محتاج عند الضغط اكثر من مرة طالما انه فى نفس التاريخ فيتم ترحيل الضغطه الى نفس العدد السابق + 1        لنفس الصنف

16-12-2020 09:55 مساء
مشاهدة مشاركة منفردة [6]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود ترحيل لمطعم
تم وضع الكود بالكامل
  تضغط على الصنف الذي تريده ثم كليك على اليوزر فتذهب الدتا الى    TextBoxes   و الى الشيت "مبيعات بدون تكرار" بالاضافى الى المعادلات اللازمة لـــ اجمالى البيع و اجمالى التكلفة
هذه المعدلات لا تعمل الا اذا كانت الخلايا في E و F و  G غير فارغة
الكود:

Dim my_sheet As Worksheet
Dim Sh As Worksheet
Dim Ro_sh%, i%, Final_Ro
Dim Rg As Range
Dim Find_what As Range
Dim Bt

'++++++++++++++++++++++++++++
Sub Debut()
  Set my_sheet = Sheets("ثوابت")
  Set Sh = Sheets("مبيعات")
   Ro = my_sheet.Cells(Rows.Count, 1).End(3).Row
   Ro_sh = Sh.Cells(Rows.Count, 2).End(3).Row + 1
  Set Rg = my_sheet.Range("a3:a" & Ro)
  Set Bt = UserForm1.ActiveControl
End Sub
'++++++++++++++++++++++++++++++++
Private Sub UserForm_Click()
  With Application
  .ScreenUpdating = fasle
  .Calculation = xlCalculationManual
  End With

Debut
 If TypeName(Bt) <> "CommandButton" Then GoTo Bay_Bay
 If Bt.Caption Like "*صنف*" Then
       Me.T_date = ""
      For i = 2 To 5
        Me.Controls("T_" & i) = vbNullString
      Next

 Set Find_what = Rg.Find(Bt.Caption, lookat:=1)
 If Not Find_what Is Nothing Then
      
        Me.T_date = Format(Date, "[$-ar-Lb] ddd d mmm yy")
      For i = 2 To 5
          Select Case i
            Case 2: st = "  بيع: "
            Case 3: st = "  تكلفة: "
            Case 4: st = "  الوزن: "
            Case 5: st = "  التصنيف: "
          End Select
             Me.Controls("T_" & i) = _
             st & my_sheet.Cells(Find_what.Row, i)
      Next
         
         With Sh.Cells(Ro_sh, 2)
         .Value = Format(Date, "[$-ar-lb] ddd d mmm yy")
         .Offset(, 2) = Bt.Caption
         .Offset(, 4) = my_sheet.Cells(Find_what.Row, 2)
         .Offset(, 5) = my_sheet.Cells(Find_what.Row, 3)
         .Offset(, 8) = my_sheet.Cells(Find_what.Row, 4)
         .Offset(, 9) = my_sheet.Cells(Find_what.Row, 5)
        End With
   Else
      GoTo Bay_Bay
  End If
 End If
 Sh.Range("B5:K" & Ro_sh + 1).RemoveDuplicates _
  Columns:=Array(1, 2, 3, 4, 5, 6, _
    9, 10), Header:=xlYes
 Final_Ro = Sh.Cells(Rows.Count, 2).End(3).Row
 If Final_Ro > 5 Then
   Sh.Range("H6:H" & Final_Ro).Formula = _
    "=IF(OR(E6="""",F6=""""),"""",PRODUCT(E6,F6))"
   Sh.Range("I6:I" & Final_Ro).Formula = _
    "=IF(OR(E6="""",G6=""""),"""",PRODUCT(E6,G6))"
  With Sh.Range("A6:K" & Final_Ro)
     .HorizontalAlignment = 1
     .InsertIndent 1
     .Borders.LineStyle = 1
     .Font.Size = 14
     .Font.Bold = True
  End With
 End If
Bay_Bay:
 With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With
End Sub

الملف مرفق
 
 
 
  Asnaf_User_Super.xlsm   تحميل xlsm مرات التحميل :(6)
الحجم :(599.017) KB



الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
لمطعم ، ترحيل ،


 










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

الساعة الآن 05:16 صباحا