شوقي ربيع

السلام عليكم الشكر موصول للاخ احمد ابوزيزو وهذا حل بسيط بالاكواد Sub test() Dim x As Long, xx As Long xx = Range("A" & Rows.Count).End(xlUp).Row For x = 3 To xx If Application.WorksheetFunction.CountIf(Range("A3:A" & xx), Range("A" & x)) > 1 Then _ Range("A" & x).Interior.Color = 65535 Next End Sub تحياتي

السلام عليكم تفضل اخي مع مرعات ان برامج الحماية تعتبره فيروس لذي ان كان برنامج الحماية لديك مفعل ممكن يعطيك خطئ او لايشتغل البرنامج اما اذا اردت ان يشتغل عادي مع وجود برنامج الحماية فلا تقم بتحويل ملف الاكسلالى ملف تنفيذي الملف المرف به ملفك محول الى ملف تنفيذي ثم الى Setup تحياتي setup.rar

السلام عليكم انضر المرفق مانفست كلابشة time.rar

السلام عليكم ضع الكود الاول في حدث اقلاع الملف هكذا Private Sub Workbook_Open() Application.OnTime TimeValue("18:08:00"), "Macro2" End Sub وباقي الاكواد اتركها في الميودل يبقى عليك ضب الوقت والتاريخ الذي يناسبك فقط تحياتي لك

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

السلام عليكم لك جزيل الشكر والتقدير لمرورك العطر و اعباراتك الجميلة تقبل مني تحياتي وتقديري

السلام عليكم لك جزيل الشكر لمرورك الطيب تقبل مني تحياتي وتقديري

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

السلام عليكم جزاك الله خيرا لمرورك لعطر تقبل مني تحياتي وتقديري

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

بسم الله الرحمان الرحيم السلام عليكم اضع بين ايديكم اليوم هذا الملف المتمثل في فورم لجلب بيانات أي عدد من صفحات الملف الى أي صفحة تريد وباي عدد من الاعمدة لكي يتم ترحيلها ارجو ان يفيدكم الملف تحياتي للجميع فورم ترحيل الصفحات.rar

السلام عليكم جرب هذا الكود يقوم باضافة حقل جديد بعد كل 30 صف ثم يضع المجاميع الخاصة بكل 30 صف للعمودين E & F و يلون صطر المجموع الى الاصفر Sub test() For R = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 30 If R <> 1 Then Range("A" & R + 1 & ":E" & R + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("E" & R + 1).Formula = "=SUM(E" & R - 29 & ":E" & R & ")" Range("F" & R + 1).Formula = "=SUM(F" & R - 29 & ":F" & R & ")" Range("A" & R + 1 & ":E" & R + 1).Interior.Color = 65535 End If Next End Sub

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

السلام عليكم شكرا اخي لتنبيهي بالمشكلة تم تعديل الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim sh As Worksheet Dim r As Integer Dim Dy Set sh = ThisWorkbook.Sheets("Sheet1") Start = True Dy = Date Do While Start For r = 5 To 100 x = sh.Range("G" & r) If sh.Range("G" & r) - Dy >= 0 Then Tamer sh.Range("H" & r).Interior.Color = 65535 Tamer sh.Range("H" & r).Interior.Pattern = xlNoneElse End If Next Loop End Sub تاريخ انتهاء الجواز والاقامه.rar

احمد.rar

السلام عليكم بالاضافة الى حل اخي جمال عبد السميع ملك المعادلات هذا حل اخر بواسطة الاكواد Sub test() Dim Sh As Worksheet Dim r As Integer, rr As Integer Set Sh = ThisWorkbook.Worksheets("Sheet1") For r = 1 To 100 Sh.Range("A" & rr + 1) = r Sh.Range("A" & rr + 2) = r Sh.Range("A" & rr + 3) = r rr = rr + 3 Next r End Sub

السلام عليكم يسعدني دائما مرورك الطيب اخي سعد تحياتي لك

السلام عليكم شكرا جزيلا لدعائك الجميل اخي الفاضلة تحياتي لكي

لسلام عليكم استخدم هذا الكود Sub test() Dim Sh As Worksheet Dim r As Integer, rr As Integer Set Sh = ThisWorkbook.Worksheets("æÑÞÉ1") rr = 0 For r = 2 To 500 Step 2 rr = rr + 1 Sh.Range("A" & r) = rr Next End Sub

السلام عليكم وميض.rar

لسلام عليكم المثال الذي ادرجته لك هو مجرد مثال لاستخدام دالة VLookup في محرر الاكواد هذا مثال يعطي نتائج العمود D Sub Test() Dim sh As Worksheet: Set sh = Sheets("bd1") Dim Table As Range: Set Table = sh.Range("F2:F41510") Dim Name As String Dim Num As Variant Dim r As Integer For r = 2 To 20 Name = sh.Range("A" & r) Num = Application.VLookup(Name, Table, 1, False) If IsError(Num) Then sh.Range("D" & r) = "áÇÊæÌÏ ÈíÇäÇÊ" Else sh.Range("D" & r) = Num End If Next End Sub

السلام عليكم تم التعديل على الملف مرن الجموعي.rar

السلام عليكم اخجلتم تواضعنا نحن مجرد تلاميذ عن حضراتكم استادي العزيز تحياتي

السلام عليكم ضع هذا الكود في زر الطباعة Dim Sh1 As Worksheet Dim Sh2 As Worksheet Set Sh1 = ActiveWorkbook.Sheets("2003") Set Sh2 = ActiveWorkbook.Sheets("ØÈÇÚÉ") Sh2.Range("B20") = Sh1.Range("H3") Sh2.Range("E22") = Sh1.Range("I3")

السلام عليكم جرب هذا Sub Vlokup() Dim Reslt As String Dim Sh As Worksheet Set Sh = ActiveWorkbook.Sheets("bd1") On Error Resume Next If IsError(Application.WorksheetFunction.VLookup(Sh.Range("A3"), Sh.Range("F2:F41510"), 1, False)) Then Reslt = "لاتوجد بيانات" MsgBox Reslt End Sub