الـعيدروس

السلام عليكم جرب التعديل التالي Private Function Ch_he(Tn As String) As Boolean Dim Ch As Hyperlink For Each Ch In ActiveSheet.Hyperlinks If Ch.TextToDisplay = Tn Then Else Ch_he = 0: Exit Function Next End Function Private Sub CommandButton12_Click() If Not Ch_he(Me.TextBox18) Then MsgBox "إرتباط غير صحيح", vbExclamation, "تنبية !!!": Exit Sub If TextBox18.Text = "" Then MsgBox ("لاتوجد صورة للعقد") Unload Me End If For Each h In Sheets("البيانات").Hyperlinks If h.TextToDisplay = TextBox18.Text Then h.Follow Exit For End If Next End Sub

اخي الفاضل حاول تلغي رمز VBA لإتاحة الوصول للأكواد وتعديلها بما يتناسب مع طلبك ثم ارفق الملف مرة اخرى تحياتي

لم أتاكد من عمل الكود مسبقاً بعد التجربه فعلا بطيء جرب التعديل التالي Public Sub Ali_Vlc() Dim Sh As Worksheet Dim Rm As Range, Rn As Range Set Sh = Worksheets("raball") With Application .ScreenUpdating = False .Calculation = xlCalculationManual Set Rm = Lr(Sh, 1, 0) Rx Sh, Rm, 46, 35: Rx Sh, Rm, 47, 8: Rx Sh, Rm, 48, 38 .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub Sub Rx(Sh As Worksheet, Rn As Range, Co As Variant, V As Integer) Dim R As Range Dim xl With Sh For Each R In Rn xl = Application.VLookup(Val®, [bd], V, False) Select Case .Cells(R.Row, Co) Case Is = "": .Cells(R.Row, Co) = "" Case IsError(xl): .Cells(R.Row, Co) = "" End Select If Not IsError(xl) Then .Cells(R.Row, Co) = xl Next End With End Sub Private Function Lr(ByVal Sh As Worksheet, ByVal Col As Variant, Optional ByVal Fst As Long) As Range With Sh Set Lr = .Range(.Cells(6, Col), .Cells(.Rows.Count, Col).End(xlUp).Offset(Fst)) End With End Function

راجع الكود مشاركة 23 =SI(ESTERREUR(SI(A6="";"";(RECHERCHEV(A6;bd;35;FAUX))));"";SI(A6="";"";(RECHERCHEV(A6;bd;35;FAUX))))

السلام عليكم حل بطريقة اخرى جرب الكود Public Sub Ali_Er() Dim Sh As Worksheet Dim Rm As Range, Rn As Range Set Sh = Worksheets("raball") With Sh Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set Rm = Lr(Sh, 1, 0) Rx Sh, Rm, 42, 35: Rx Sh, Rm, 43, 8: Rx Sh, Rm, 45, 38 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End With End Sub Sub Rx(Sh As Worksheet, Rn As Range, Co As Variant, V) With Sh For Each R In Rn xl = Py_m(R, Range("bd"), V) If IsError(xl) Then .Cells(R.Row, Co) = "" Else .Cells(R.Row, Co) = xl If R.Value = "" Then .Cells(R.Row, Co) = "" Next End With End Sub Private Function Lr(ByVal Sh As Worksheet, ByVal Col As Variant, Optional ByVal Fst As Long) As Range With Sh Set Lr = .Range(.Cells(6, Col), .Cells(.Rows.Count, Col).End(xlUp).Offset(Fst)) End With End Function Private Function Py_m(Em, Hn_a As Range, Vl) Dim R With Hn_a For R = 1 To .Rows.Count If .Cells(R, 1) = Em Then Py_m = .Cells(R, Vl) End If Next End With End Function

السلام عليكم جرب هذا الكود Public Sub Ali_nr() Dim c As Long Dim x As Long c = 11 For Each Rn In Array("j", "k", "l", "m", "n", "o") x = Evaluate("=SUMPRODUCT((raball!AQ$6:AQ$60000=B17)*(raball!AS$6:AS$60000=C2)*(raball!" & Rn & "$6:" & Rn & "$60000)*(date>=F$2)*(date<=G$2))") Cells(17, c) = x c = c + 1 Next End Sub

لايوجد معادلات في المدى الذي ذكرته ؟ ( K17:P18 )

في اي ورقة المعادلة ؟ بحثت عليها في الملف ولم اجدها ارجو التوضيح

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

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

السلام عليكم ارفق ملف وبه الداله وإن شاء الله خير

السلام عليكم عذرا اخي احمد لم ارى ردك ويمكن استخدام المتغير في وسط الكود بتغير الـ Dim إلى Static Static i As Integer هذا النوع من المتغيرات التي تخزن القيمة وقت التشغيل

اخي الحبيب حماده عمر اشكرك جزيل الشكر على مرورك العطر الله يسلمك من كل شر نحمد الله على كل حال شواغل الدنيا إن شاء الله نتواجد عما قريب جزاك الله خير الاخ الفاضل هاني مصطفى الحمد لله ان الكود يعمل معك وضع المتغير في اعلى الواجهه يسمى متغير عام اي بالامكان استدعاء المتغير من اي كود اخر وهنا استخدم عام ليتم استخدامه عند الضغط على الزر حاول تضيف المتغير وسط الكود وجرب استخدم الزر بتلاحظ انه لم يعمل لانك وضعته في وضع خاص وسط الكود اي بمعنى انه لم يتعرف البرنامج على قيمة المتغير كي يضيف له رقم 1 لكي يعطيك قيمة السطر التالي i = i + 1 هذا والله اعلم والسموحه على الاطاله حبيت افصل لك الاجابه كي تستوعب بشكل افضل

السلام عليكم بعد اذن الاستاذ احمد عبدالناصر تعديل على الكود إن شاء الله يفي بالغرض '********************* ' مدى البيانات Private Const A_nm As String = "$B$5:$B$221" Dim i As Integer Private Sub CommandButton1_Click() If Range(A_nm).SpecialCells(2).Count = i Then MsgBox " ( انتهت البيانات ) ": Exit Sub TextBox1.Value = Sheets("Sheet1").Cells(i + 5, "b") i = i + 1 End Sub Private Sub UserForm_Activate() CommandButton1_Click End Sub تحياتي

السلام عليكم أرفق مثال وإن شاء الله سيتم تلبية الطلب

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

السلام عليكم بعد اذن استاذي عبدالله جرب التعديل التالي على الكود Private Sub Ent_a() Dim m On Error GoTo 1 m = WorksheetFunction.Match(CStr(Me.TextBox1), Range("a1:a6"), 0) 1: If Err Then MsgBox "القيمة غير موجودة في القائمة" TextBox1 = "" Err.Clear End If End Sub Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Select Case KeyCode Case 1 To 46 If Not TextBox1 = "" Then Ent_a End Select End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Not TextBox1 = "" Then Ent_a End Sub

السلام عليكم بعد اذن الاساتذه الافاضل او بهذ الشكل طبعا الكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Column = 2 And .Row > 1 Then .Offset(0, -1) = IIf(IsNumeric(.Offset(-1, -1)), .Offset(-1, -1), 0) + 1 End If End With End Sub

السلام عليكم الكود بيكون بهذا الشكل Public Sub A_Add() [D8] = Join(Application.Index([D6:I6].Value, 0), "") End Sub

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

السلام عليكم تفضل فورم_A.rar

السلام عليكم تفضل

السلام عليكم شاهد المرفق انقر على الزر المسمى English أرجو ان يفي بالغرض و ينال استحسانك GENIUS_A.rar

جرب هذا التعديل Public Sub Ali_Fmla_To_VBA() Dim Sht As Worksheet Dim R As Range, Rr As Range Dim Ar_Ads(), Ar_Fm() Dim F, Lc, Prmit_A, Rw Call Ad_Refe: Call Ali_Delet: Call Ali_M Dim A Dim B Dim C Set A = ThisWorkbook.VBProject Set C = A.VBComponents.Item("My_Frmola").CodeModule On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For Each Rr In Sht.Range(Rng).SpecialCells(xlCellTypeFormulas) If Not IsEmpty(Rr) Then ReDim Preserve Ar_Ads(0 To F) ReDim Preserve Ar_Fm(0 To Lc) Ar_Ads(Lc) = "Sheets(""" & Rr.Worksheet.Name & """)" & "." & "Range(""" & Rr.Address(0, 0) & """)" '************************************************ Ar_Fm(F) = "=" & "Evaluate(""" & IIf(InStr(1, Rr.Formula, """", vbTextCompare) > 0, Replace(Rr.Formula, """", """"""), Rr.Formula) & """)" '************************************************ F = F + 1: Lc = Lc + 1 End If Next Next With C .AddFromString ("Sub Ali_Formola" & vbCrLf) For Prmit_A = LBound(Ar_Ads) To UBound(Ar_Ads) N = .CountOfLines .InsertLines N, Ar_Ads(Prmit_A) & Ar_Fm(Prmit_A) N = N + 1 Next .InsertLines N + 1, vbCrLf & "End Sub" End With Erase Ar_Ads: Erase Ar_Fm End Sub

السلام عليكم جرب استخدم الكود التالي للملفين بطاطس وببسي واما الترحيل للملف Sheets لم يتوفر لدي الوقت غدا إن شاء الله Public Sub Ta() Dim S As Worksheet Dim Rn As Range Set T = Sheets("total") T.Range(T.Cells(2, 1), T.Cells(T.Rows.Count, 16)).ClearContents Application.ScreenUpdating = 0 For Each S In ThisWorkbook.Worksheets If S.Name Like "شهر" & "*" Then For Each Rn In S.Range("A10:A" & S.Cells(Rows.Count, 1).End(xlUp).Row) If Not IsEmpty(Rn) Then With S Lr = T.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row Union(.Cells(Rn.Row, "H"), .Cells(Rn.Row, "I"), .Cells(Rn.Row, "O"), _ .Cells(Rn.Row, "P"), .Cells(Rn.Row, "V"), .Cells(Rn.Row, "W")).Copy T.Range("C" & Lr).PasteSpecial xlPasteValues End With End If Next End If Next End Sub