عبدالله باقشير

السلام عليكم هذه دالة معمولة بالكود ضعها في موديل Option Explicit Function kh_Cont(RngName As Range, RngCont As Range) Dim Obj As Object Dim Txt As String Dim iCont As Long, R As Long ''''''''''''''''''''''''''''' Set Obj = CreateObject("Scripting.Dictionary") ''''''''''''''''''''''''''''' iCont = RngCont.Rows.Count ''''''''''''''''''''''''''''' For R = 1 To iCont If Val(RngCont.Cells(R, 1)) Then Txt = RngName.Cells(R, 1) If Not Obj.Exists(Txt) Then Obj.Add Txt, R End If End If Next kh_Cont = Obj.Count ''''''''''''''''''''''''''''' Set Obj = Nothing End Function وضعها هكذا في الخلية F39 =kh_Cont($C$2:$C$33;F2:F33) واسحبها على باقي الاعمدة واخبرني بالنتيجة تحياتي

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

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

لا داعي للاعتذار اخي الحبيب تقبلوا تحياتي وشكري

السلام عليكم ليس له علاقة بما ذكرت وانما كانت الارقام مرتبة وكان موضع الصف يوخذ حسب الترتيب عموما استخدم الكود التالي Sub kh_Start() Dim Cel As Range Dim R As Integer, rr As Integer, c As Integer '============== On Error Resume Next c = WorksheetFunction.Match([D3], ورقة2.Range("H1:BQ1"), 0) + 1 If Err Then MsgBox "من فضلك ادخل البيانات بشكل كامل" Exit Sub End If On Error GoTo 0 '============== For Each Cel In Range("C6:C12") If Val(Cel) Then rr = WorksheetFunction.Match(Val(Cel), ورقة2.Range("A3:A10000"), 0) With ورقة2.Range("A3").Cells(rr, c) .Offset(0, 6).Value = Cel.Offset(0, 2).Value .Offset(0, 7).Value = Cel.Offset(0, 3).Value End With End If Next kh_Clear End Sub تحياتي

السلام عليكم يتم الحفظ في فولدر ملف الاكسل وباسماء مرتبة تسلسلية تبدأ من 1 شاهد المرفق 2010 sallll.rar

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

هو يعمل عندي بالرغم من وجود صيغ خطا

السلام عليكم الكود التالي لا يحتاج الى تسمية الزر Sub kh_zoom() Dim Ary Dim shp As Shape Dim txt As String, txt1 As String Dim z As Integer Set shp = ActiveSheet.Shapes(Application.Caller) Ary = Array("تكبير", "تصغير") txt = shp.TextFrame.Characters.Text If txt = Ary(1) Then z = 50: txt1 = Ary(0) Else z = 200: txt1 = Ary(1) ActiveWindow.Zoom = z shp.TextFrame.Characters.Text = txt1 End Sub جرب واشعرنا بالنتيجة تحياتي

السلام عليكم هل جربت التنسيق التالي للخلية من تنسيق خلايا محاذاه اتجاه النص من اليمين الى اليسار تحياتي

السلام عليكم هل هذا الكود المستخدم Sub kh_trheel() Dim Ary Dim M As Long, Mt As Long Dim Txt As String On Error Resume Next Txt = [B4] & [A6] & [B12] With ورقة4 M = .Cells(.Rows.Count, "A").End(xlUp).Row Mt = WorksheetFunction.Match(Txt, .Range("i2").Resize(M), 0) If Mt Then If MsgBox("تم توثيق البيانات من قبل" & vbCr & "هل تريد مواصلة الترحيل??", vbYesNo, "تاكيد") = vbNo Then GoTo 1 End If Ary = Array(M, [B4], [A6], [B14], [E14], [G14], [B12], [a10], [B8], [A16], [A16], [B16], [A20], [B20], Txt) .Cells(M + 1, 1).Resize(1, 9).Value = Ary MsgBox ("شكرا--- تم توثيق الافادة") End With 1: End Sub

السلام عليكم حول هذا السطر الى بداية الكود On Error Resume Next وافحص عمل الكود بعد الترحيل

الخلايا التي ترحل منها يجب ان لا يكون فيها علامات الخطا

السلام عليكم صحح اسم الورقة من Feuil4 الى ورقة4 تحياتي

جرب هذا الكود في الملف الذي في مشاركة الاخ حمادة رقم 12 Option Explicit '////////////////////////////////////////////////////// Sub kh_AddNamePicture() Dim MyObj, MyObjFol, Obj Dim iPath As String Dim Last As Long, i As Long '============================ On Error GoTo Err_kh_Files '============================ iPath = ActiveWorkbook.Path & "\" Set MyObj = CreateObject("Scripting.FileSystemObject") Set MyObjFol = MyObj.GetFolder(iPath) '============================ For Each Obj In MyObjFol.Files If Not Dir(Obj.Path, vbDirectory) = "" Then If ActiveWorkbook.Name = Obj.Name Then GoTo 1 i = i + 1 Cells(i + 1, "A").Value = Obj.Name End If 1 Next '============================ Err_kh_Files: If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear Set MyObj = Nothing: Set MyObjFol = Nothing End Sub تحياتي

السلام عليكم تم اضافة هذا السطر الى الكود If C.Value = "" Then GoTo 1 وهذا الكود بعد التعديل Sub Circles1() Dim C As Range Dim MyRng As Range, v As Shape Dim X As Integer, G As Integer, R As Integer, D As Integer '================================================ Set MyRng = Range("F5:M405") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ X = ActiveWindow.Zoom Application.ScreenUpdating = False ActiveWindow.Zoom = 100 For Each C In MyRng If C.Value = "" Then GoTo 1 If (C.Value < 50 Or C.Value = "غائب" Or C.Value = "صفر") Then Set v = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6) v.Fill.Visible = msoFalse v.Line.ForeColor.SchemeColor = 10 v.Line.Weight = 1.75 D = D + 1 End If 1 Next ActiveWindow.Zoom = X Application.ScreenUpdating = True MsgBox "تم إضافة " & D & " دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله" End Sub تحياتي

السلام عليكم في جزئية مهمة في الكود هذا السطر لا ينفع في الارتباط مع (الاسم المركب) للورقة يعني لما يكون اسم الورقة اكثر من كلمة واحدة SubAddress:=sht.Name & "!a1" وعلشان يرتبط مع الكل هكذا يكون SubAddress:="'" & sht.Name & "'!a1" تحياتي

السلام عليكم Sub listallsheets2() Dim sht As Worksheet Dim i As Integer i = 2 For Each sht In Worksheets i = i + 1 ActiveSheet.Hyperlinks.Add _ Anchor:=Cells(i, 2), _ Address:="", _ SubAddress:="'" & sht.Name & "'!a1", _ TextToDisplay:=sht.Name Next sht End Sub تحياتي

هذا الحل لا ينفع الا بالفرز

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

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

السلام عليكم شاهد المرفق 2010 المصنف2.rar

السلام عليكم يجب ان تكون قائمة الاسماء مفروزة تصاعديا المرفق 2010 تصفيه.rar

السلام عليكم حسب ما فهمت والله اعلم جرب هذه المعادلة =IF(ISERROR(VLOOKUP(A2;'موافقات البصرة'!$A$2:$H$782;8;0));"( ليس لديه موافقة )";VLOOKUP(A2;'موافقات البصرة'!$A$2:$H$782;8;0)) تحياتي

اللهم ياسامع دعاء كل محب لهذا الرجل الذى لم يدخر يوما جهدا على كل تلميذ من تلامذتة هذا الرجل الخلوق أن تشفية وتجعل كل هذه الدعوات له مستجابة وتلبسة لباس العافية والصحة " أمين يارب العالمين "