الـعيدروس

السلام عليكم ألاخ ابو الحسن ولايهمك انت أامر جرب المرفق ALIDROOS_F1.rar

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

السلام عليكم اخي ابو الحسن للعتديل يكون كالتالي البارتشن :C الملف الاول مثلا اسمه A الملف الثاني اسمه B الاسم الثالث اسمه C ثم ملف الاكسل اسمه Ahssan بيكون كالاتي C:\A\B\C\Ahssan.xls

السلام عليكم بعد اذن الاخوة الاحبه جرب هذا الكود Public Sub Ali_Tqrar() On Error Resume Next Dim Wh As WorksheetFunction Set Wh = Application.WorksheetFunction For c = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 If Cells(c, 1) < 0 Or Cells(c, 1) > 0 Then '********************************************************************* ' لحذف الأرقام المتشابه بالسالب أو الموجب مثلا -5 و 5 يعتبر تشابه يحذف If Wh.CountIf(Abs(Range("A1:A" & c)), Abs(Cells(c, 1))) = 1 Then Cells(c, 1).EntireRow.Delete ElseIf Cells(c, 1) > 0 Then '********************************************************************* ' لحذف المكرر من الأرقام الموجبه 'If Wh.CountIf(Range("A1:A" & c), Cells(c, 1)) = 1 Then Cells(c, 1).EntireRow.Delete End If Next End Sub

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

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

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

السلام عليكم استاذي الحبيب طارق محمود ارجو تجربة هذا الكود في حدث الورقة رغم اني لم افهم طريقة التحديث التي تنشط الدوال المركبه هل المقصود F2 ثم Enter اكثر من مره للخليه ؟ Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.Count = 1 And Target.HasFormula = True Then Target.Calculate End Sub

السلام عليكم بعد استخدام الكود انسخ هذا الكود في الملف الجديد وشغله إن شاء الله تزبط معك الألوان Public Sub Ali_Form() Dim R As Range, Rn As Range Dim Ct As FormatCondition With ActiveSheet Set R = .Range("A1:J102").SpecialCells(xlCellTypeAllFormatConditions) With Application .ScreenUpdating = False: .EnableEvents = False For Each Rn In R For C = 1 To Rn.FormatConditions.Count Set Ct = Rn.FormatConditions(C) If Ct.Interior.ColorIndex Then Ct.Interior.Color = 14474738 End If Next Next .ScreenUpdating = True: .EnableEvents = True End With End With End Sub

السلام عليكم Alt F11 ثم Insert من القائمة نختار Module ثم تلصق الكود فيه ولاتنسى تغير إسم الورقتين "ورقة1" و "ورقة2" من الكود حسب إسم الورقتين في ملفك ثم تدرج زر وتخصص له الكود

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

السلام عليكم الاخ الفاضل zarouki2000 بعد إستخراج أرقام الأيدي للأجهزة تحطها في المنغيرات PC Private Sub Workbook_Open() Dim PC1$, PC2$, PC3$, PC4$, PC5$ PC1 = "F0E1D85A" ' رقم الايدي للجهاز 1 PC2 = "F0E1D85B" ' رقم الايدي للجهاز 2 PC3 = "F0E1D85C" ' رقم الايدي للجهاز 3 PC4 = "F0E1D85D" ' رقم الايدي للجهاز 4 PC5 = "F0E1D85E" ' رقم الايدي للجهاز 5 With CreateObject("Scripting.FileSystemObject") If Hex(.Drives.Item("c:").SerialNumber) = PC1 Or Hex(.Drives.Item("c:").SerialNumber) = PC2 _ Or Hex(.Drives.Item("c:").SerialNumber) = PC3 Or Hex(.Drives.Item("c:").SerialNumber) = PC4 _ Or Hex(.Drives.Item("c:").SerialNumber) = PC5 Then MsgBox "تفضل بالدخول" Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر " ThisWorkbook.Close savechanges = True End If End With End Sub جرب الكود واخبرنا بالنتائج

السلام عليكم الاخ الفاضل Waaly بعد اذن اخي الحبيب محمود علي اطلع على المرفق waaly.rar

اخي أبو حنين انا جربت الأكواد على نطاقات مضافة عن طريق يسار الصيغة الأوفيس عندي 2007

السلام عليكم اتبع شرح الكود ونسخ الأسطر الموضحه في الكود للأكواد الأخرى وإن شاء الله سوف تعمل Sub Excel4us2() '************************ ' إلغاء الحماية للورقة النشطه ActiveSheet.Unprotect "1" '************************ On Error Resume Next Cells.EntireRow.Hidden = False Sheets("2").PageSetup.PrintArea = "A1:O132" Sheets("2").PrintOut copies:=2 '************************ ' حماية الورقة بعد تنفيذ الكود ActiveSheet.Protect "1" '************************ End Sub

السموحه منك أخي أبو حنين لم أرى مشاركتك إلا بعد المشاركه

ألسلام عليكم وهذه بطريقة الأكواد هذا الكود لإعادة تسمية نطاق معين Public Sub Rnm_Ali() Dim Nam_Rn As Name Dim Rms As Long Dim A_Rnm As String For Each Nam_Rn In Names Rms = MsgBox(" هل هذا النطاق المراد إعادة تسميته " & Nam_Rn.Name _ & vbNewLine & "الذي يشير للمدى: " & Nam_Rn.RefersTo, _ vbQuestion + vbYesNoCancel, "إعادة تسمية") If Rms = vbCancel Then Exit Sub If Rms = vbYes Then With Nam_Rn A_Rnm = InputBox("إدخل التسمية الجديدة للنطاق", "الأسم الجديد") If A_Rnm = "False" Or A_Rnm = cnacel Or IsNumeric(A_Rnm) Then Exit Sub .Name = A_Rnm MsgBox " تم بنجاح إعادة تسمية النطاق إلى الإسم التالي :" & A_Rnm: Exit Sub End With End If Next Nam_Rn End Sub وهذا الكود لإعادة تحديث النطاق الى نطاق اخر Public Sub Refe_Ali() Dim Nam_Rn As Name Dim Rms As Long On Error Resume Next Dim Re_Rn As Range For Each Nam_Rn In Names Rms = MsgBox(" هل تريد تحديث هذا النطاق " & Nam_Rn.Name _ & vbNewLine & "الذي يشير للمدى: " & Nam_Rn.RefersTo, vbQuestion + vbYesNoCancel, "حذف نطاق") If Rms = vbCancel Then GoTo Nex If Rms = vbYes Then Anm = Nam_Rn.Name With ThisWorkbook.Names(Anm) 0: Set Re_Rn = Application.InputBox("حدد بالماوس المدى المراد بدلا من النطاق السابق.", "إعادة تعين نطاق", , , , , , 8) If Re_Rn Is Nothing Then Re_Rn = MsgBox("التحديد ليس مدى هل تريد اعادة تحديد المدى ؟ ", vbOKCancel + vbQuestion) If Re_Rn = vbCancel Then Exit Sub Else GoTo 0 End If Else .RefersTo = Re_Rn.Address MsgBox " تم بنجاح تحديث النطاق إلى النطاق الجديد " & .RefersTo Exit Sub End If End With End If Nex: Next Nam_Rn End Sub وهذا لحذف نطاق معين Public Sub DNam_Ali() Dim Nam_Rn As Name Dim Rms As Long For Each Nam_Rn In Names Rms = MsgBox(" هل تريد حذف النطاق المسمى " & Nam_Rn.Name _ & vbNewLine & "الذي يشير للمدى: " & Nam_Rn.RefersTo, _ vbQuestion + vbYesNoCancel, "حذف نطاق") If Rms = vbCancel Then Exit Sub If Rms = vbYes Then Nam_Rn.Delete Next Nam_Rn End Sub أرجو تجربة الأكواد تقبلو تحياتي

السلام عليكم جرب هذا الكود تفعيل الكود يحمي الورقتين تفعيل مره اخرى يلغي الحماية عن ورقتين Public Sub Proc() Const Pas As String = "123" For Each i In Array("ورقة1", "ورقة2") With Sheets(i) If .ProtectContents = False Then .Protect Pas .EnableSelection = xlUnlockedCells Else .Unprotect Pas .EnableSelection = xlUnlockedCells End If End With Next End Sub

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

السلام عليكم جزاك الله كل خير اخي أبو حنين فكرة رائعه جدا المشكله التي صادفت أستاذي الحبيب أحمد زمان اضن أن الويندوز المستخدم لديه غير الـ Xp بحيث لايسمح بإنشاء ملف تكست أوبرنامج في الـقرص C:\Abu.txt مباشرة لابد أن يكون في مجلد أنا عدلت بالكود أنشات مجلد في الـ C بأسم Ali وأضفت ملفين تكست Abu و Hainine والنقطه الثانيه أنه في حدث Workbook open يوجد هذه الأسطر وهيا تقوم بحذف الملفين قبل الكتابة عليهم If Dir("C:\Ali\Abou.txt") <> "\" Then Kill "C:\Abou.txt" Kill "C:\Hainine.txt" End If أضن أنها تتضلل بعد تعديل المسار عندي الى الشكل التالي وتضليل أسطر حذف الملفين عمل الكود ولاكن ملف بعد التغيير فقط أما قبل التغير فارغ Open "C:\Ali\Hainine.txt" For Append As #1

الحمد لله الذي بنعمته تتم الصالحات

لايوجد مرفق ؟

ارفق مثال وبه شرح ماتريد اضغط ملف الاكسل بأحد برامج الضغط WinRAR أو WinZip ثم أرفقه

مثل ماتفضل اخي عبدالله المجرب جرب التعديل التالي علما أنه بيغلق الملفان لانهم بنفس الاسم Sub outsheet() On Error Resume Next MyWok = ActiveSheet.Name & ".xlsb" MYPATH = Environ("homedrive") & Environ("HOMEPATH") & "\desktop" & "\" & MyWok If Dir(MYPATH) = "" Then Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=MYPATH, FileFormat:=xlExcel12, CreateBackup:=False Application.Windows(2).Activate MsgBox ("تم نقل الملف إلى سطح المكتب") Windows(MyWok).Close Else Application.DisplayAlerts = False If MsgBox(" هذا الملف موجود مسبقا هل تريد إستبداله ", vbYesNo, "الملف موجود مسبقا") = vbNo Then Exit Sub ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=MYPATH, FileFormat:=xlExcel12, CreateBackup:=False Application.Windows(2).Activate MsgBox ("تم إستبدال الملف ونقله إلى سطح المكتب ") Windows(MyWok).Close Application.DisplayAlerts = True Exit Sub End If End Sub

السلام عليكم اشكرك على كلامك الطيب والمشجع جرب المرفق فتح_A.rar