ابراهيم الحداد

السلام عليكم ورحمة الله اخى الكريم قم فقط بتغيير ارقام الشيتات فى الكود لتتناسب مع رقم الشيت الموجود بها الشيكبوكس مثلا Sheet1.Shapes("Check Box 1") تصبح Sheet2.Shapes("Check Box 1") وهكذا

السلام عليكم ورحمة الله الكود الاول لاظهار واخفاء الخطين و يربط بالشيكبوكس الاول Sub AddStright() If Sheet1.Shapes("Check Box 3").OLEFormat.Object.Value = 1 Then Sheet1.Shapes("Straight Connector 3").Visible = msoTrue Sheet1.Shapes("Straight Connector 2").Visible = msoTrue Else Sheet1.Shapes("Straight Connector 3").Visible = msoFalse Sheet1.Shapes("Straight Connector 2").Visible = msoFalse End If End Sub الكود الثانى للاثنين الباقيين و يربط بهما الواحد تلو الاخر Sub AddWords() Dim Frst As String, ForB As String Frst = " للمستفيد الأول" ForB = "يصرف لحامله" If Sheet1.Shapes("Che

السلام عليكم ورحمة الله استخدم المعادلة التالية =LOOKUP(2;1/($B2:$E2<>"");$B2:$E2) او المعادلة التالية =INDEX($A$2:$E$5;MATCH(J3;$A$2:$A$5;0);LARGE(IF($B2:$E2<>"";COLUMN($B2:$E2));1))

السلام عليكم ورحمة الله اخى الكريم لقد فهمت من المشاركة الاولى انك تريد اضافة ورقة لكل موظف ومن ثم اضافة البيانات التى تخصه فقط فى تلك الورقة ان كان فهمى هذا صحيحا فيمكنك استخدام الكودين الاتيين الاول لاضافة ورقة جديدة لاى موظف جديد و الثانى لترحيل البيانات الخاصة به الى ورقته اليك الكود الاول يربط الزر الخاص بتنفيذ الكود بالكود الثانى Sub CreateAcc() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, Rng As Range, C As Range Set ws = Sheets("Salary04 (2)") LR = ws.Range("F" & Rows.Count).End(3).Row Set Rng = ws.Range("F3:F" & LR) On Error Resum

السلام عليكم ورحمة الله تفضل SpllingWord.xlsb

السلام عليكم ورحمة الله جرب هذه الدالة المخصصة Function SepLetrs(Cel As Range) As String Dim Arr, Tmp, Word, Strg Dim i As Long, j As Long Arr = Array("ا", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", _ "ض", "ع", "غ", "ط", "ظ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "و", "ي", "ى", "ة") Tmp = Array("الف", "باء", "تاء", "ثاء", "جيم", "حاء", "خاء", "دال", "ذال", _ "راء", "زين", "سين", "شين", "صاد", "ضاد", "عين", "غين", "طاء", "ظاء", _ "فاء", "قاف", "كاف", "لام", "ميم", "نون", "هاء", "واو", "ياء", "ياء", "تاء مربوطة") For i = 1 To Len(Cel) Word = Mid(Cel, i, 1) For j = LBo

السلام عليكم ورحمة الله استخدم الكود التالى و لكن يجب عليك الغاء الهايبرلنك الذى يربط الزر بورقة حساب حتى يعمل معك الكود Sub fildata() Dim lr As Long lr = Sheets("شهر3").Range("A" & Rows.Count).End(3).Row Sheets("حساب").Activate Sheets("حساب").Range("A3").Value = Sheets("شهر3").Range("A" & lr).Value End Sub

السلام عليكم ورحمة الله اذا كنت لا تريد عمل زر لتنفيذ الكود يمكنك وضع هذا الكود فى حدث الورقة "كشف حساب" Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$6" Then Call GetData End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub GetData() Dim ws As Worksheet, Sh As Worksheet Dim ShNam As String, Arr As Variant, XSum As Double Dim i As Long, j As Long Set ws = Sheets("كشف حساب") ws.Range("B9:L14").ClearContents ShNam = ws.Range("H6").Text Set Sh = Sheets(ShNam) XSum = Sh.Range("K6").Value Arr = Sh.Range("B11:L" & Sh.Range("K" & Rows.Count).End(xlUp).Row).Value ws.Range("B9").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr ws.Range("D16") = XSum End Sub

السلام عليكم ورحمة الله اجعل المعادلة هكذا =INDEX(B2:AA5;MATCH(E13;A2:A5;0);MATCH(D13;B1:AA1;0))

السلام عليكم ورحمة الله فى كود التفقيط استبدل هذه الفقرة Else .Value = "فقط " & Texte1 & St2 بتلك الفقرة Else .Value = "فقط " & Texte1 & Stx1 & St2 و تنتهى المشكلة باذن الله

السلام عليكم ورحمة الله الحاقا بالمشاركة السابقة ( بعد ان وقع سهوا) فى كود دالة التفقيط استبدل هذه الفقرة MyNumber = Abs(Number_Value) MyNumber = Int(MyNumber) بتلك الفقرة If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) حتى يعمل معك الكود بشكل سليم .... فيصبح الكود كاملاً Public Function Ar_WriteDownNumber(Number_Value As String, Optional Main_Currency As String, Optional Small_Currency As String, Optional Main_To_Small_Factor As Integer) Dim MyNumber Dim MyFracti

السلام عليكم ورحمة الله اجعل الكود هكذا Sub TEST() Dim Sh As Worksheet, LR As Long, Cel As Range Dim Stx1 As String, Stx2 As String, St1 As String, St2 As String, Texte1 As String, Texte2 As String For Each Sh In Worksheets(Array("DATA")) LR = Sh.Cells(Sh.Rows.Count, 17).End(xlUp).Row Stx1 = "جنيها ": Stx2 = "قرشا ": St1 = "و ": St2 = "لا غير" 'كيف يمكن تعديل هذين السطرين لتفقيط خانتى القرش والجنيه الملونه باللون الاصفر Texte1 = Ar_WriteDownNumber(Cells(LR, "Q")) Texte2 = Ar_WriteDownNumber(Cells(LR, "P")) With Sh.Cells(LR + 2

السلام عليكم ورحمة الله اخى الكريم ضع المعادلة التالية فى الخلية "B5" ثم اضغط Ctrl+Shift+enter ثم اسحب نزولا =IFERROR(INDEX(ورقة1!$A$2:$C$152;SMALL(IF(ورقة1!$A$2:$A$152=$F$2;ROW(ورقة1!$A$2:$C$152));ROW(A1))-1;3);"") اما المعادلة التالية فضعها فى الخلية "C5" و كرر ما سبق =IFERROR(INDEX(ورقة1!$A$2:$C$152;SMALL(IF(ورقة1!$A$2:$A$152=$F$2;ROW(ورقة1!$A$2:$C$152));ROW(A1))-1;2);"")

السلام عليكم ورحمة الله استخدم هذه المعادلة =IFNA(VLOOKUP($A2;التحميل!$A$2:$B$1000;2;0);VLOOKUP($A2;مستودع!$A$2:$B$1000;2;0))