الـعيدروس

الاخ الحبيب يوسف خليل الكود يعمل على 2007 ومافوق للمعلوميه فقط وهذا المرفق كمثال Ali_Condict.rar

عذرا تأكدت من الدالة بها خطاء جرب هذا التعديل Public Function Ali_Cond(ByVal My_r As Range, Cond As String, Nu_Colr As Long) As Long Dim R As Range Dim F_A As WorksheetFunction Dim Ali_c As FormatConditions Dim A_Dou As Double A_Dou = 0 Set F_A = Application.WorksheetFunction Debug.Print F_A.CountA(My_r) For Each R In My_r Set Ali_c = R.FormatConditions Select Case Ali_c(1).Interior.ColorIndex Case Is = Nu_Colr And IIf(Cond = "", R.Text = Cond, R.Text <> "") If F_A.CountA(My_r) = 0 And Cond = "" Then GoTo 0 If F_A.CountA(My_r) > 0 And Cond = "" Then GoTo 0 A_Dou = A_Dou + 1 End Select 0 Next Ali_Cond = A_Dou End Function

اخي الفاضل zarouki2000 الظاهر نسخت الكود قبل التعديل الاخير ملاحظة مسمى t ليس به اي خليه لونها اصفر اذا نتيجة المعادلة بتكون = 0 انسخ الكود التالي او الذي في المشاركة السابقة في انتظار ردك Public Function Ali_Cond(ByVal My_r As Range, Cond As String, Nu_Colr As Long) As Long Dim R As Range Dim Ali_c As FormatConditions Dim A_Dou As Double A_Dou = 0 For Each R In My_r Set Ali_c = R.FormatConditions Select Case Ali_c(1).Interior.ColorIndex Case Is = Nu_Colr And IIf(Cond = "", R.Text = Cond, R.Text > "") If R.Interior.ColorIndex = Nu_Colr Then A_Dou = A_Dou + 1 End Select Next Ali_Cond = A_Dou End Function

ارجو منك ارفاق المثال وبه نتائج ماتريد كي اعرف طلبك بالشكل الصحيح تقبل تحياتي

الكود ينقصه اغلاق الشرط If بـ End if وحلقة التكرار بـ Next ونهاية الكود بـ End sub ليكون كالتالي Sub a() Dim cl As Range If [b1] = "" Then Exit Sub For Each cl In Range("b3:b" & [b1000].End(xlUp).Row) If cl.Value < 5000 Then Sheets("a").Range("a" & Sheets("a").[a1000].End(xlUp).Row + 1) = cl.Offset(0, -1) Sheets("a").Range("b" & Sheets("a").[b1000].End(xlUp).Row + 1) = cl.Offset(0, 1) End If Next End Sub

السلام عليكم جرب هذه المعادلة المركبه إستخدامها كالتالي =Ali_Cond(TAM;"";6) المعيار الاول المدى المعيار الثاني رقم اللون المعيار الثالث شرط جمع الفارغه ام التي بها بيانات Public Function Ali_Cond(ByVal My_r As Range, Cond As String, Nu_Colr As Long) As Long Dim R As Range Dim Ali_c As FormatConditions Dim A_Dou As Double A_Dou = 0 For Each R In My_r Set Ali_c = R.FormatConditions Select Case Ali_c(1).Interior.ColorIndex Case Is = Nu_Colr And IIf(Cond = "", R.Text = Cond, R.Text > "") If R.Interior.ColorIndex = Nu_Colr Then A_Dou = A_Dou + 1 End Select Next Ali_Cond = A_Dou End Function ارجو التجربه

السلام عليكم بعد اذن الاساتذة الاحبه بن عليه و dahmour Public Sub Ali_Abc() With Rows("6:" & Cells(Rows.Count, 1).End(xlUp).Row) .Sort Key1:=Cells(6, 2), Order1:=xlDescending, Header:=xlNo End With End Sub

جرب ترجمة الاسم الموجود في الملف

السلام عليكم اخي سعد عابد حسب فهمي لطلبك جرب هذا الكود Dim Sh As Worksheet Public Sub Ali_T() Dim S As Worksheet Dim Rn As Range Dim R Set S = Sheets("مشتريات") Set Sh = Sheets("RR") Rw = 6 L_r = S.Cells(Rows.Count, 2).End(xlUp).Row Set Rn = S.Range(S.Cells(5, 1), S.Cells(L_r, 10)) With Application .ScreenUpdating = False .EnableEvents = False With Rn For R = 1 To .Rows.Count If .Cells(R, 1).Value >= S.[J1] And .Cells(R, 1).Value <= S.[K1] Then If .Cells(R, 6) = S.[F2] Then S.Range(.Cells(R, 2), .Cells(R, 9)).Copy Sh.Cells(Rw, 2).PasteSpecial xlPasteValues Rw = Rw + 1 End If End If Next End With .CutCopyMode = False .EnableEvents = True .ScreenUpdating = True End With If WorksheetFunction.CountA(Sh.Range("B6:B10")) >= 2 Then Ali_Ds End Sub Private Sub Ali_Ds() Dim Rn, L_Rn As Range Dim A_di As Object Dim A_Sum(), V_Rn() Dim A_i As Long, E, Dc, L_r, L_rr As Long Set Sh = Sheets("RR") With Application .ScreenUpdating = False .EnableEvents = False Sh.Activate .ScreenUpdating = False L_r = Sh.Cells(.Rows.Count, "B").End(xlUp).Row + 1 Set Rn = Sh.Range("B6:I" & L_r) Rn.Select V_Rn = Rn.Value ReDim A_Sum(1 To UBound(V_Rn, 1), 1 To 8) Set A_di = CreateObject("Scripting.Dictionary") With A_di For A_i = 1 To UBound(V_Rn, 1) If Not .exists(V_Rn(A_i, 1)) Then E = E + 1 For Dc = 1 To 8 A_Sum(E, Dc) = V_Rn(A_i, Dc) Next Dc .Add V_Rn(A_i, 1), E ElseIf .exists(V_Rn(A_i, 1)) Then A_Sum(.Item(V_Rn(A_i, 1)), 7) = A_Sum(.Item(V_Rn(A_i, 1)), 7) + V_Rn(A_i, 7) End If Next A_i End With L_rr = ActiveSheet.UsedRange.Rows.Count Set L_Rn = Range("B6:I" & L_rr) L_Rn.Clear Sh.Range("B6").Resize(E, 8).Value = A_Sum .EnableEvents = True .ScreenUpdating = True End With End Sub فاتورة_A.rar

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

اشكرك اخي ياسر على كلماتك الطيبه وهذا التعديل الاخير للداله لكل الحالات Private Const MyBegTx As String = "" Private Const MyTNum As String = "ألف" Private Const Ad As String = " في اليوم " Private Const Am As String = " من شهر " Private Const Ay As String = " عام " Public Function Ali_IsD(ByVal S_D As Range) As String Dim Ar(), Arr(), Ar1(), Arr1() Dim Dy, Mn, Ya, Mr, R_S Ar = Array("جانفي", "فيفري", "مارس", "افريل", "ماي", "جوان", "جويلية", "اوت", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر") '******************************************** Arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر" _ , "الحادي عشر", "الثاني عشر", "الثالث عشر", "الرابع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر" _ , "التاسع عشر", "العشرين", "الواحد والعشرين", "الثاني والعشرين", "الثالث والعشرين", "الرابع والعشرين" _ , "الخامس والعشرين", "السادس والعشرين", "السابع والعشرين", "الثامن والعشرين", "التاسع والعشرين", "الثلاثين", "الواحد والثلاثين") If InStr(S_D.Text, "/") = 0 Then MsgBox "القيمة المدخلة ليس بصيغة تاريخ", vbExclamation, "تنبية !!!": Exit Function For Rr = LBound(Arr) To UBound(Arr) If CLng(Day(S_D)) = Rr + 1 Then Dy = Arr(Rr): Exit For Next For Mr = LBound(Ar) To UBound(Ar) If CLng(Month(S_D)) = Mr + 1 Then Mn = Ar(Mr): Exit For Next Ali_IsD = Ad & Dy & Am & Mn & Ay & kh_TextNum(Year(S_D)) End Function من حمل مرفق المشاركة السابقة يرجاء تحميل المرفق مرة اخرى وأي ملاحظات انا موجود تم تعديل ملاحظت اخي يوسف عطا تقبلو تحياتي وشكري تحويل التاريخ حروف _A.rar

السلام عليكم اخي الحبيب ياسر الخليل اشكر على هذه الملاحظة القيمة اذا التاريخ يكتب البداية السنه التعديل في المعادلة الاول كالتالي Public Function Ali_IsD(ByVal S_D As Range) As String Dim Ar(), Arr(), Ar1(), Arr1() Dim Dy, Mn, Ya, Mr, R_S Ar = Array("جانفي", "فيفري", "مارس", "افريل", "ماي", "جوان", "جويلية", "اوت", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر") '******************************************** Arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر" _ , "الحادي عشر", "الثاني عشر", "الثالث عشر", "الرابع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر" _ , "التاسع عشر", "العشرين", "الواحد والعشرين", "الثاني والعشرين", "الثالث والعشرين", "الرابع والعشرين" _ , "الخامس والعشرين", "السادس والعشرين", "السابع والعشرين", "الثامن والعشرين", "التاسع والعشرين", "الثلاثين", "الواحد والثلاثين") If InStr(S_D.Text, "/") = 0 Then MsgBox "القيمة المدخلة ليس بصيغة تاريخ", vbExclamation, "تنبية !!!": Exit Function For Rr = LBound(Arr) To UBound(Arr) If CLng(Day(S_D)) = Rr + 1 Then Dy = Arr(Rr): Exit For Next For Mr = LBound(Ar) To UBound(Ar) If CLng(Month(S_D)) = Mr + 1 Then Mn = Ar(Mr): Exit For Next Ali_IsD = Ad & Dy & Am & Mn & Ay & kh_TextNum(Year(S_D)) End Function

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

السلام عليكم تفضل جرب هذا الكود Public Sub Ali_t() Dim Sh As Worksheet Dim S As Worksheet Dim Ar, Rw, R, C, Rr, Cc Set Sh = ورقة1 Set S = ورقة2 Rr = 14: Cc = 1 Ar = Array(2, 3, 4, 17, 20, 23, 26, 29, 32, 35, 38, 41, 42, 46, 49, 52, 55, 59, 62) Rw = Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False For C = LBound(Ar) To UBound(Ar) For R = 14 To Rw If Sh.Cells(R, 1) <> "" Then Cl = Ar(C) S.Cells(R, Cc) = Sh.Cells(R, Cl) End If Next Cc = Cc + 1 Next Application.ScreenUpdating = True End Sub

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

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

السلام عليكم بعد اذن اخي الحبيب ياسر خليل هذه محاولة معادلة مركبه مع الاستعانه بدالة التفقيط للعلامه خبور خير حفظه الله تدرج الاكود التالية في مودويل استعمال المعادلة كالاتي =Ali_IsD(خلية التاريخ) Private Const MyBegTx As String = "" Private Const MyTNum As String = "ألف" Private Const Ad As String = " في اليوم " Private Const Am As String = " من شهر " Private Const Ay As String = " عام " Public Function Ali_IsD(ByVal S_D As Range) As String Dim Ar(), Arr(), Ar1(), Arr1() Dim Dy, Mn, Ya, Mr, R_S Ar = Array("جانفي", "فيفري", "مارس", "افريل", "ماي", "جوان", "جويلية", "اوت", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر") '******************************************** Arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر" _ , "الحادي عشر", "الثاني عشر", "الثالث عشر", "الرابع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر" _ , "التاسع عشر", "العشرين", "الواحد والعشرين", "الثاني والعشرين", "الثالث والعشرين", "الرابع والعشرين" _ , "الخامس والعشرين", "السادس والعشرين", "السابع والعشرين", "الثامن والعشرين", "التاسع والعشرين", "الثلاثين", "الواحد والثلاثين") If InStr(S_D.Text, "/") = 0 Then MsgBox "القيمة المدخلة ليس بصيغة تاريخ", vbExclamation, "تنبية !!!": Exit Function For Rr = LBound(Arr) To UBound(Arr) If CLng(Day(S_D)) = Rr + 1 Then Dy = Arr(Rr): Exit For Next For Mr = LBound(Ar) To UBound(Ar) If CLng(Month(S_D)) = Mr + 1 Then Mn = Ar(Mr): Exit For Next Ali_IsD = Ad & Dy & Am & Mn & Ay & kh_TextNum(Year(S_D)) End Function Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", " ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ين")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function تحويل التاريخ حروف _A.rar

كتابة التاريخ بالحروف جانفي فيفري في أي لغة فرنسية ام ماذا ؟

الاستاذ الحبيب عبدالله المجرب اشكرك على مرورك الكريم وكلماتك الطيبه

السموحه على هذا الخطاء تفضل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, [B4:AH4]) Is Nothing Then With ActiveSheet Cells.UnMerge Dim Rw$ E = Cells(Rows.Count, 3).End(xlUp).Row Rw = "5:" & E .Rows(Rw).Sort Key1:=.Cells(5, Target.Column), Order1:=xlAscending, Header:=xlNo .Cells(5, Target.Column).HorizontalAlignment = xlRight Cancel = True ' .Rows(Rw).Sort Key1:=.Cells(5, Target.Column), Order1:=xlDescending, Header:=xlNo ' .Cells(5, Target.Column).HorizontalAlignment = xlRight ' Cancel = True End With End If End Sub

هذا الكود في حدث الورقة قبل تنفيذ الكود الغي جميع الخلايا المدموجه اضفت سطر في الكود لإلغاء الخلايا المدموجة للفرز لأي عمود انقر مرتين في عنوان العمود السطر الخامس Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, [B4:AH4]) Is Nothing Then With ActiveSheet Cells.UnMerge Dim Rw$ E = Cells(Rows.Count, 3).End(xlUp).Row Rw = "5:" & E .Rows(Rw).Sort Key1:=.Cells(5, 2), Order1:=xlAscending, Header:=xlNo .Cells(5, 2).HorizontalAlignment = xlRight Cancel = True ' .Rows(Rw).Sort Key1:=.Cells(5, 2), Order1:=xlDescending, Header:=xlNo ' .Cells(5, 2).HorizontalAlignment = xlRight ' Cancel = True End With End If End Sub

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

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

السلام عليكم هذه الأسطر إحذفها من الكود وإن شاء الله يزبط معك If Dir(Path_F & A_M & ".jpg") <> "" Then Kill Path_F & A_M & ".jpg" End If تقبل تحياتي وشكري

اخي الحبيب يوسف خليل مايقصده استاذي عبدالله تغير لغة الكتابة عند الكتابة اذا كانت الكتابة عربي جرب الكود واذا كانت انجليزي غير اللغة "Shift" + "Alt" ثم جرب انسخ هذه احتمال وبرضه فيه احتمال اخر ربما تكون من اعدادات محرر الأكواد Tools ثم Options ثم Editor Format في كمبوكس الـ Font إختار الخط التالي Courier New (العربية) أرجو أن تعمل معك