الـعيدروس

أي كود تقصد و ماذا يظهر ؟؟

السلام عليكم جرب هذا الكود Sub alidroos_com() For R = 2 To 18 If Application.WorksheetFunction.CountIf([D2:D18], Cells(R, 1)) = 0 Then With Columns(6).Rows(65536).End(xlUp) .Offset(1, 0) = Cells(R, 1) .Offset(1, 1) = Cells(R, 4) End With End If Next End Sub

السلام عليكم الاخ الحبيب cat101 اثنان من الاخوة الاحبة يعمل معهم الملف بشكل طبيعي عند البحث عن إسم معين يلزمك تختار الإسم من الليست بكوس ثم تدوس زر إضافة

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

السلام عليكم قائمة References ثم Browse وفي حقل File name انسخ هذا الرابط ثم موافق C:\Windows\SysWOW64\MSCOMCTL.OCX

السلام عليكم من أعمال الاستاذ القدير خبور خير SerH.rar

السلام عليكم الاخ الفاضل طاهر إذهب إلى قائمة References وإبحث عن هذه الجملة Microsoft Windows Common Controls 6.5 (SP6) وحفز علامة الصح وموافق إن شاء الله يعمل معاك

السلام عليكم الاخ ابو تميم اعذرني الطلب الأول لاأعلم من قال لااعلم فقد افتى الطلب الثالث غير واضح ماهو الملف المسار الحقيقي وغير الحقيقي ؟ ماهو ملف العمل ودونه ؟؟

السلام عليكم إلغي علامة الصح من عليها وإضغط ok وجرب إن شاء الله يعمل معاك أو إستعن بهذا الكود بدلا من ذلك Sub ali1() Dim Ref For Each Ref In ThisWorkbook.VBProject.References If Ref.IsBroken = True Then ThisWorkbook.VBProject.References.Remove Ref Next Ref End Sub

الاح طاهر عند النقر على اوك اضغط زر ايقاف الماكرو بعدها تذهب للقائمة Tools References

كود تغير لون الفورم عند فتحه كل مره استخدام الكود في حدث الفورم Private Sub UserForm_Activate() Application.EnableEvents = False Dim R As Integer, B As Integer, G As Integer R = Rnd * 255 B = Rnd * 255 G = Rnd * 255 UserForm1.BackColor = RGB(R, B, G) Application.EnableEvents = True End Sub

كود إضافة بيانات في Combobox مباشرة من الورقة وبدون تكرار يستخدم الكود في حدث UserForm Private Sub UserForm_Initialize() Dim i As Integer For i = 1 To Sheets("ورقة1").Range("A65536").End(xlUp).Row ComboBox1 = Sheets("ورقة1").Range("A" & i) If ComboBox1.ListIndex = -1 Then ComboBox1.AddItem Sheets("ورقة1").Range("A" & i) Next i End Sub

كود إلغاء دمج الخلايا Sub UnMergeSelected() Selection.MergeCells = False End Sub

كود إخفاء خلاياء معينه من الطباعة بالتلاعب بالتنسيق ثم استعادة التنسيق الاصلي بعد الطباعه يستخدم الكود في مودويل Option Explicit Option Base 1 Sub test() On Error Resume Next Dim M As Range: Set M = Range("A4:F5") ' المدى ALI_HID_C Sheets(1), M End Sub Sub ALI_HID_C(ALI_SH As Worksheet, SH_A As Range) Dim F_ALI() As Variant Dim Cell As Range Dim i As Integer ReDim Preserve F_ALI(SH_A.Cells.Count) For Each Cell In SH_A i = i + 1 F_ALI(i) = Cell.NumberFormat Next Cell SH_A.NumberFormat = ";;;" ورقة1.PrintPreview i = 0 For Each Cell In SH_A i = i + 1 Cell.NumberFormat = F_ALI(i) Next Cell End Sub

كود تحديد الخلايا التي فيها معادلات لمدى متفرق تلوين الخط كود يستخدم في مودويل Sub UnionDemo() Dim MyUnion As Range Set MyUnion = Union(Range("A1:A15"), Range("D4:E15")) For Each cell In MyUnion If cell.HasFormula = True Then cell.Font.ColorIndex = 3 End If Next cell End Sub

كود إستبدال كلمة مكرره في الشيت إلى كلمة اخرى Sub ReplaceDemo() Dim sht As Worksheet For Each sht In Worksheets sht.Cells.Replace What:="أحبك", _ Replacement:="أحبك كثير", LookAt:=xlPart, MatchCase:=False Next End Sub

كود انشاء TextBox Activesheet وإضافة تنسيقات عليه مثل الخط Sub AddTextBox() ActiveSheet.Shapes.AddTextBox(msoTextOrientationHorizontal, 2.5, 1.5, 116, 145).TextFrame.Characters.Text = Range("a1").Value With Selection.Characters(Start:=1, Length:=216).Font .Name = "Traditional Arabic" .FontStyle = "bold" .Size = 15 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Range("I15").Select End Sub

كود عمل سطر فارغ بين كل سطر وسطر من مدى تحدده بالماوس Sub InsertarFilas2() Dim ii As Long, C As Range On Error Resume Next Set C = Application.InputBox("ضلل اسطر البيانات دون رؤس الاعمدة", Type:=8) On Error GoTo 0 If C Is Nothing Then Exit Sub Application.ScreenUpdating = False With C(1) ii = .CurrentRegion.Rows.Count - 1: .EntireColumn.Insert With .Offset(1, -1).Resize(ii) .Value = Evaluate("row(" & .Address & ")") End With With .Offset(1 + ii, -1).Resize(ii - 1) .Value = Evaluate("0.5 + row(" & .Offset(-ii).Address & ")") End With .Offset(1).Resize(2 * ii - 1).EntireRow.Sort Key1:=.Offset(1, -1), Order1:=xlAscending, Header:=xlNo .Offset(, -1).EntireColumn.Delete End With Application.ScreenUpdating = True End Sub

كود لمعرفة الفورم الموجودة في المصنف في رسالة إستخدام الكود في مودويل Sub listeUserFormClasseur() Dim VBCmp For Each VBCmp In ThisWorkbook.VBProject.VBComponents If VBCmp.Type = 3 Then MsgBox VBCmp.Name Next VBCmp End Sub

كود نسخ جميع التعليقات إلى ورقة جديدة وتفاصيل اخرى للتعليقات أكتشفها بنفسك Sub ShowCommentsAllSheets() Application.ScreenUpdating = False Dim commrange As Range Dim mycell As Range Dim ws As Worksheet Dim newwks As Worksheet Dim i As Long Set newwks = Worksheets.Add newwks.Range("A1:E1").Value = Array("Sheet", "Address", "Name", "Value", "Comment") For Each ws In ActiveWorkbook.Worksheets On Error Resume Next Set commrange = ws.Cells.SpecialCells(xlCellTypeComments) On Error GoTo 0 If commrange Is Nothing Then Else i = newwks.Cells(Rows.Count, 1).End(xlUp).Row For Each mycell In commrange With newwks i = i + 1 On Error Resume Next .Cells(i, 1).Value = ws.Name .Cells(i, 2).Value = mycell.Address .Cells(i, 3).Value = mycell.Name.Name .Cells(i, 4).Value = mycell.Value .Cells(i, 5).Value = mycell.Comment.Text End With Next mycell End If Set commrange = Nothing Next ws newwks.Cells.WrapText = False newwks.Columns("E:E").Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Application.ScreenUpdating = True End Sub إستخدام الكود في مودويل

كود لفتح قائمة المنسدلة في مدى معين عند المرور على الخلية يوفر وقت النقر كليك على الخلية الكود يستخدم في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Set r = [a2:a100]: Set r1 = [b2:b100] If Not Intersect(Target, r) Is Nothing Then With Application .Goto Target.Offset(, 1) .SendKeys ("%{DOWN}") End With ElseIf Not Intersect(Target, r1) Is Nothing Then Target.Offset(1, -1).Select End If End Sub

السلام عليكم جزاك الله خير اخ محمد مصطفى موضوع جميل جدا بعد اذنك هذا كود تغير لون الفورم من كود استخدامه من مودويل Sub A() ThisWorkbook.VBProject.VBComponents("UserForm1").Properties("backcolor") = RGB(255, 125, 125) End Sub

حل اخر محرر الأكواد قائمة Tools ثم Editor Format ثم Font غير الخط مثلا Traditional Arabic (Arabic)

السلام عليكم بعض التعديلات للكود تفضل Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Dim R As Range If Application.WorksheetFunction.CountBlank(Range(Cells(2, 6), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 6))) = 0 Then GoTo 0 Application.EnableEvents = False For Each R In Range("F2:F500") If R.Value = Empty Then R.EntireRow.Delete End If Next R Application.EnableEvents = True 0: Lrw = [A10000].End(xlUp).Row With Sheets("ASE02") .[A2:BZ10000].ClearContents For RT = 2 To Lrw For C = 2 To 12 .Cells(RT, C).Value = Cells(RT, C).Value Next Next End With Application.ScreenUpdating = True End Sub

السلام عليكم الاخ الفاضل apt ماالويندوز الذي لديك اذا كان مافوق XP اذهب الى إعدادات اللغة ثم إداري ثم تغير الإعدادات المحلية للنظام تظهر قائمة اختار اللغة العربية منها وإن شاء الله يعمل معك مزبوط صار لي مثل مشكلتك قبل شهر ونفس هذه الطريقة تم حل المشكلة