الـعيدروس

السلام عليكم الاستاذ المهندس طارق محمود حفظك الله ماشاء الله حل جميل عمل استفدت منه في عملي بارك الله فيك استاذنا ونفع بعلمك تقبل مروري

السلام عليكم طيب حصرنا الشرط موجب الخليه نفسها جرب هكذا Public Sub ALI_F() On Error Resume Next Application.DisplayAlerts = False Dim F_ALI, R_ALI As Range, T As Integer F_ALI = Array(Range("E2"), "/") For T = 0 To 3 For Each R_ALI In Range("D7", Range("D" & Rows.Count).End(xlUp)) If InStr(R_ALI, F_ALI(T)) <> 0 Then GoTo 1 Exit Sub Else If R_ALI.Value <> "" Then R_ALI.Value = [E2].Value & " _ " & R_ALI.Value End If 1 Next R_ALI Next T Application.DisplayAlerts = True End Sub sh1.rar

السلام عليكم الاخ الفاضل skyblue هل جربت الكود الاخير الذي في المشاركة السابقة والذي هو هذا ولم يزبط معك ام ماذا ؟؟؟ Public Sub ALI_F() Dim F_ALI, R_ALI As Range, T As Integer F_ALI = Array("2011", "/", "01", "11", "12", "_", "1") For T = 0 To 3 For Each R_ALI In Range("D7", Range("D" & Rows.Count).End(xlUp)) If InStr(R_ALI, F_ALI(T)) <> 0 Then GoTo 1 Exit Sub Else If R_ALI.Value <> "" Then R_ALI.Value = [E2].Value & " _ " & R_ALI.Value End If 1 Next R_ALI Next T End Sub

السلام عليكم هل هكذا تقصد Private Sub Workbook_Open() Application.ScreenUpdating = False Application.EnableEvents = False If sheet1.Cells(1, 256).Value = Empty Then sheet1.Cells(1, 256).Value = "1" Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets With sh .[B4].Formula = "=I3-I4" .[I4].Formula = "=I3-SUMPRODUCT(($B$5:$B$25003<>""الاجمالى"")*($E$5:$H$25003))" End With Next sh Exit Sub End If Application.ScreenUpdating = True Application.EnableEvents = True End Sub

الاخ الفاضل khhanna إن امكن ترفق الحل كي نستفيد ويستفيد الاخوة وفقك الله

السلام عليكم على وضع ملفك الحالي على انه لايوجد بيانات بعد اخر خلية التي هيا الجمع بيكون هكذا Sub ALI_A() Dim Q, T As Long Q = Range("H4").End(xlDown).Row Range("F" & Q).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove T = Cells(4, 6).End(xlDown).Row Cells(T + 1, 6).Value = 1 ' هذا السطر كمثال إدخال قيم Cells(T + 1, 7).Value = 2 ' هذا السطر كمثال إدخال قيم Cells(T + 1, 8).Formula = "=SUM(RC[-2],RC[-1])" End Sub والسلام عليكم

السلام عليكم اطلع على المرفق shrh.rar

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

السلام عليكم بالنسبة لطباعة الفورم بدون الإطار مافية غير كود الاستاذ الحبيب محمد يحياوي أ و احاول اتحكم بمدى التقاط الصورة اذا زبط معي ولا إنتظر عمالقة المنتدى

السلام عليكم بعد اذن الاستاذ الحبيب عبدالله المجرب اولاً استخدم هذا الكود لقراءة رقم ID الهارد ثم اكتب الايدي في مذكرة رقم الايدي نفسه اذا كانت الحروف كبتل عادة بيكون كبتل مع ارقام هذا الكود Sub ALI_HARD() With CreateObject("Scripting.FileSystemObject") MsgBox Hex(.Drives.Item("c:").SerialNumber) End With End Sub Private Sub Workbook_Open() With CreateObject("Scripting.FileSystemObject") If Hex(.Drives.Item("c:").SerialNumber) = "XXXX" Then MsgBox "تفضل بالدخول" Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر " ThisWorkbook.Close savechanges = True End If End With End Sub وبعدها تحط ID في الشرط بدال الاكسات ( XXXX ) بهذا السطر If Hex(.Drives.Item("c:").SerialNumber) = "XXXX" Then الية الكود اذا حاولت استخدام الملف في جهاز اخر لن يفتح لان رقم الايدي غير مطابق والسلام عليكم وبعد حفظ رقم الايدي حط هذا الكود في حدث ThisWorkbook

السلام عليكم جرب المرفق انقر وسط الفورم ولاحظ هل هذا طلبك PACTF_ALI.rar

الحمد لله انك توصلت لطلبك كلام فعلا مزبوط بالنسبة لاكواد VB6 واكواد VBA Excel متقاربة جدا وهيا نفسها ولاكن الفرق في المسميات هذا والله اعلم

السلام عليكم اخي الفاضل emailehtiaty ارجو منك عمل ملف بسيط كمثال وارفاقه وعليه شرح مبسط كي يسهل علينا عمل المطلوب

السلام عليكم اطلع على المرفق ان شاء الله يعجبك تنقر مرة على الزر يظهر الفورم تنقر مرة اخرى على الزر يختفي الفورم botion_alidroos.rar

السلام عليكم الكود الذي يظهر نجوم لااعلم لمن هوا ولاكن نقول جزاه الله كل خير جرب المرفق alidroos_B_1.rar

السلام عليكم الاخ الفاضل الفدائي فتح ملف اكسل جديد عن طريق VB6 فيجول يختلف من فتح ملف اكسل جديد من ملف اكسل لاادري هل يزبط معاك بهذا الشكل Dim Exl As Excel.Application Dim MyDB As Excel.Workbook Sub NweSheeetCustomeName() Dim SheetName As String Workbooks("MyDB").Select SheetName = Text1.Text If SheetName = "" Or Len(SheetName) > 31 Then MsgBox ("You did not insert a name OR sheet name lenth is greater than 31 Characther") Exit Sub Else With ActiveWorkbook.Sheets .Add after:=Worksheets(Worksheets.Count) End With ActiveSheet.Name = SheetName End If End Sub

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

السلام عليكم للاسف لااعلم ولاكن عندك خاصية البحث لدى الموقع إن شاء الله تلقاه وإن كنت تريد كود يقوم لتصوير نطاق معين تفضل هكذا بيكون الكود Sub ALI_PACT() On Error Resume Next Dim ALI_R As Range Set ALI_R = Range("A2:F20") ALI_R.Copy ActiveSheet.Pictures.Paste.Select With ALI_R.ShapeRange.Fill.ForeColor .SchemeColor = 9 End With With ALI_R.ShapeRange.PictureFormat .TransparentBackground = False End With With ALI_R .ShapeRange.Width = ALI_R .ShapeRange.Height = ALI_R .Application.CutCopyMode = False End With End Sub غير المدى الذي تريد من هذا السطر Set ALI_R = Range("A2:F20") والسلام عليكم

اطلع على المرفق واذا لم يكن المطلوب الرجاء التوضيح اكثر الساعات الإضافية_1.rar

السلام عليكم استخدم هذه المعادلة =IF(OR(D8<10,E8<35),"",1) حسب نوع النقطه الفاصلة بين الصيغ لدى جهازك =IF(OR(D8<10;E8<35);"";1)

اللهم اشفه انت الشافي قال رسول الله صلى الله عليه وسلم مايصيب المؤمن من وصب ولا نصب ولا سقم ولا حزن حتى الهم يهمه إلا كفر الله به من سيئاته

السلام عليكم هذا الكود فرضاً أنا إسم الفورم USERFORM1 UserForm1.PrintForm

السلام عليكم استخدم هذا الكود واربطه مع أي زرار تحب Sub ali() ThisWorkbook.Save End Sub

السلام عليكم ماتم عمله عند دخولك الملف والذهاب الى ورقة محمد قمت بإدخال الرقم السري خطاء يرجعك الى ورقة 1 اعدت الدخول لورقة محمد ادخلت الرقم السري خطاء مرة اخرى يرجعك الى ورقة 1 مرة اخرى دخلت ورقة محمد ادخلت الباسورد صحيح خلاص يقفل تروح الى اي ورقة وترجع لورقة محمد لايطلب منك الباسورد الا بعد اغلاق المصنف وفتحه يرجع يعمل نفس الحركه ارجو أن يفي بالغرض alidroos_B.rar

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