اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

حسين مامون

الخبراء
  • Posts

    1,284
  • تاريخ الانضمام

  • Days Won

    6

كل منشورات العضو حسين مامون

  1. اضف هذا السطر للكود في الزر المسمى "تعديل" If TextBox6 = "" Then MsgBox "المرجو ادخال الرمز في المربع الاصفر ": Exit Sub الصورة
  2. اخي الكريم كلنا نعرف عند تنفيذ الماكرو يتم الغاء خاصية التراجع في الاكسيل يمكنك انشاء عمود مساعد لهذه الغاية مثلا اضافة سطر للكود ترحيل قيمة الخلية النشطة ازاحة بمقدار ما يناسب هكذا يحفظ القيمة السابقة ولاسترجاعها انشاء كود بسيط ينقد هذا الامر
  3. بما انك لم ترفع ملف نمودج عما تريد اليك هاذا الشيء ربما تستفيذ منه listC.xlsm
  4. جرب المرفق Private Sub Worksheet_Change(ByVal Target As Range) Dim WS1 As Worksheet: Set WS1 = Sheets("Vacation_Registor") WS1.ListObjects("الجدول520").Range.AutoFilter Field:=1 WS1.ListObjects("الجدول520").Range.AutoFilter Field:=5 Dim RG1, RG, RG2 Dim lr1, lr Dim x Application.ScreenUpdating = False If [c2] = "" Then MsgBox "المرجو اختيار الاسم اولا": Exit Sub If Not Intersect(Target, Range("c3")) Is Nothing Then '==================== Set RG1 = ListObjects("الجدول119").Range lr1 = RG1.Find(WHAT:="*", AFTER:=RG1.Cells(1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _ searchdirection:=xlPrevious, MatchCase:=False).Row + 1 Range("b5:e64").ClearContents '==================== WS1.Range("a2:g2").AutoFilter WS1.ListObjects("الجدول520").Range.AutoFilter Field:=1, Criteria1:=Range("c2") WS1.ListObjects("الجدول520").Range.AutoFilter Field:=5, Criteria1:=Target '==================== Set RG = WS1.ListObjects("الجدول520").Range lr = RG.Find(WHAT:="*", AFTER:=RG.Cells(1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _ searchdirection:=xlPrevious, MatchCase:=False).Row If lr = 2 Then Exit Sub WS1.Range("b3:e" & lr).Copy Range("b5").PasteSpecial ' Range("a5:a" & lr + 1).Formula = "=IF(B5="""","""",SUBTOTAL(103,$B$5:B5))" WS1.ListObjects("الجدول520").Range.AutoFilter Field:=1 WS1.ListObjects("الجدول520").Range.AutoFilter Field:=5 End If Application.ScreenUpdating = True End Sub الملف تجربة 1 (1) (1).xlsm
  5. ادخل بعض البيانات في الشيت كما تتصورها ثم ارفعه والله المستعان
  6. اخي الكريم اعطينا هذا الموضوع اكثر مما يستحق وهذا مخالف لقانون المنتدى وكل هذا لانك لم توصل الفكرة عما تريد بلغة الاكسيل لاخر مشاركة ارجو ان تشرح ما دور الكود الدي تتحدث عنه ادا طبق ايعمل على العمودE الكود في مشاركتي السابقة يغي بالغرض وينبهك في بملاحضة بالعمود F انسخه وضعه في حدثworkbook_open ارجو بعض الاخوة الاطلاع على الملف وابداء اراء لان الاخ يقول الملف لايفتح عنده تحياتي
  7. الكود الاول في حدث Workbook_Open وهو يفعل كود test2 ثم يخفي الاكسيل ويظهر الفورم Private Sub Workbook_Open() test2 Application.Visible = False UserForm1.Show End Sub وهذه صورة الكود داخل محرر الاكواد وهذه الاكواد داخل الفورم Private Sub CommandButton1_Click() ThisWorkbook.Save Application.Quit End Sub Private Sub CommandButton2_Click() Unload Me Application.Visible = True Sheets(1).Activate End Sub صورة الفورم وهذا الكود في مديول Sub test2() Dim lr Dim x, m lr = Cells(Rows.Count, "d").End(3).Row For x = 3 To lr Dim DT1, DT2 If CDate(Cells(x, "e")) = Date Then Cells(x, "f").Value = "هذا الشيك حان موعده" Cells(x, "f").Interior.Color = 255 Else Cells(x, "f").Interior.Color = xlNone Cells(x, "f").Value = "" End If Next x وهذه صور للصفحة
  8. حافظه شيكات.xlsm
  9. حافظه شيكات.xlsm عندي شغال 100/100 وهذه صورة هذا الكود انسخه الى ملفك Sub test2() Dim lr Dim x, m lr = Cells(Rows.Count, "d").End(3).Row For x = 3 To lr Dim DT1, DT2 If CDate(Cells(x, "e")) = Date Then Cells(x, "f").Value = "هذا الشيك حان موعده" Cells(x, "f").Interior.Color = 255 Else Cells(x, "f").Interior.Color = xlNone Cells(x, "f").Value = "" End If Next x End Sub
  10. جرب هذا حافظه شيكات.xlsm
  11. هل تقصد انك تريد كود vba لتنبيه عند انتهاء التاريخ المحدد في العمود E?
  12. اخي الكريم ملفك ينقصه مزيدا من الشرح لما تقصد هذا طلبك الاول ولكن لم افهم فيه شيء تقوا تريد ان يكون التطبيق على التواريخ في العمود E ولكن كيف؟ ١ الشرح كان على خانه واحدة فى عمود (e5 )اريد ان يكون التطبيق على التواريخ الموجوده فى العمود( e) بالكامل اشرح ما تريد بالتفصيل بالنسبة للطلب الثاني انسخ هذا الكود وضعه في الزر لي في الفورم Private Sub CommandButton2_Click() Unload Me Sheets(1).Activate End Sub
  13. استعمل هذا الكود واكتفي بزر واحد فقط Sub RN() If Not Intersect(Columns(3), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = Val(ActiveCell + 1) '======= ElseIf Not Intersect(Columns(5), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell = "x" & ActiveCell ActiveCell.Offset(, 8) = "x" '======= ElseIf Not Intersect(Columns(8), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = ActiveCell ActiveCell = "x" & ActiveCell '======= ElseIf Not Intersect(Columns(10), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 4) = "x" ActiveCell = "x" & ActiveCell End If End Sub الترحيل بالماكرو (1).xlsb
  14. مرحبا اخي الكريم جرب المرفق الترحيل بالماكرو.xlsb
  15. Sub test1() If Not Intersect(Columns(3), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = Val(ActiveCell + 1) ActiveCell.Offset(, 3) = Val(ActiveCell + 1) End If End Sub Sub test2() If Not Intersect(Columns(8), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = Val(ActiveCell) ActiveCell.Offset(, 3) = Val(ActiveCell) If ActiveCell = 40 Then ActiveCell = ActiveCell & "x" End If End Sub
  16. جربهدا نشط اي خلي عي العمود c او h Sub test1() If Not Intersect(Columns(3), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = Val(ActiveCell + 1) End If End Sub Sub test2() If Not Intersect(Columns(8), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = Val(ActiveCell) End If End Sub كود ترحيل قيمة أي خلية نشطة الى خلية مجاورة بزيادة واحد.xlsm
  17. جرب هذا الشيء Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim WS2 As Worksheet Set WS2 = Sheets("Price list Gouna") Dim RG, lr Dim x, RT Set RG = WS2.ListObjects("Table2").Range Set RT = ActiveSheet.Range("k3:k120000") lr = RG.Find(WHAT:="*", AFTER:=RG.Cells(1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _ searchdirection:=xlPrevious, MatchCase:=False).Row '================== If Not Intersect(Target, RT) Is Nothing Then For x = 3 To lr If WS2.Cells(x, 1).Text = Target Then Target.Offset(, -1).Value = WS2.Cells(x, 3).Value Target.Offset(, -3).Value = WS2.Cells(x, 2).Value Exit For End If Next x End If End Sub 1096400303_test(5).xlsm
  18. اخي الكريم يمكن لاسم واحد ان يتكرر ايضا في اجازتين والتاريخ كذلك يمكن ان يتكرر فلا ار ى هذا حلا لموضوعك ما رايك في اضافة عمود يسمى "رقم الاجازة" وكل اججازة تحمل رقم ويتغير في الطلب بعد كل ترحيل انظر المرفق تجربة 1 (1).xlsm
  19. تجربة بالنسبة للترحيل من شيت Vacation Letter الى Vacation_Registor اتمنى ان يكون ما تريد تجربة 1 (1).xlsm
  20. ربما تقصد هذا استعلام رقم الجلوس.xls
  21. ارفعي صورة عن الخطأ واشرحي المطلوب بالظبط
  22. انسخي هذا الكوذ الى الزر الذي تريدين وضعيه بين السطرين Private Sub CommandButton2_Click() و end sub الكود بسيط يمكنك التعديل عليه حسب السكستبوكس او العمود المرحل اليه اضيفي تسكستبوك الذي تريدين Dim lr lr = Cells(Rows.Count, 2).End(3).Row + 1 Range("b" & lr).Value = TextBox4.Value Range("c" & lr).Value = TextBox5.Value Range("d" & lr).Value = TextBox6.Value TextBox4 = "" TextBox5 = "" TextBox6 = ""
×
×
  • اضف...

Important Information