سليم حاصبيا

جرب ان تكتب في الملف التالي مصرية او مسلمة خطأ في التنسيق salim1.rar

اخي يجب اولاً كنابة النوع و من ثم كتابة الجنسية او الديانة حتى و لو كانت مكتوبة

لا تنسَ ايضاً حرف الياء المشترك بين الثلاثة (مرتين لكل واحد)

ربما يجب استبدال الكود بهذا (من الضروري تجربة الكود على ملف وهمي او نسخة احتياطية قبل ذلك) Sub talween1() For x = 1 To Sheets.Count With Sheets(x) ro = .Cells(Rows.Count, "O").End(3).Row For Each cell In .Range("o1:O" & ro) If IsNumeric(cell) And cell.Value < 0 Then cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = 3 Else cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = vbBlack End If Next End With Next End Sub

مشكور جداً اخي غبد العزيز ما اوتينا من علم ذلك بفضل هذا المنتدى الرائع رجاء اذعب الى هذا العنوان اترى احد الابداعات الجديدة اخي ياسر ربما يوجد معلومات في النطاق المطلوب لا يجب استعمال ClearContents في هذه الحالة

جرب هذا الكود Sub extract_time() Dim mycol As New Collection Dim mytext lr = Cells(Rows.Count, "F").End(3).Row For i = 2 To lr x = Application.WorksheetFunction.Trim(Range("f" & i).Value) On Error Resume Next For t = 1 To Len(x) y = Mid(x, t, 1) If IsNumeric(y) Or Asc(y) = 46 Or Asc(y) = 58 Then mycol.Add y mytext = mytext & y End If Next Cells(i, 7) = mytext * 1 mytext = "" Next End Sub

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

عسى ان يكون المطلوب جرب هذا الكزد Sub talween() ro = Cells(Rows.Count, "O").End(3).Row Range("a1:o" & ro).ClearFormats For Each cell In Range("o1:O" & ro) If IsNumeric(cell) And cell.Value < 0 Then cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = 3 End If Next End Sub حاجة سهلة كل شيء بالكود متعلق بالحرف O استبدله الى M و استبدل الرقم 14- ب 12- و الرقم 15 ب 13 وأخيراً اين الاعجاب بالكود

عسى ان يكون المطلوب جرب هذا الكود Sub talween() For x = 1 To Sheets.Count With Sheets(x) ro = .Cells(Rows.Count, "O").End(3).Row .Range("a1:o" & ro).ClearFormats For Each cell In .Range("o1:O" & ro) If IsNumeric(cell) And cell.Value < 0 Then cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = 3 End If Next End With Next End Sub

عسى ان يكون المطلوب talween.rar

انسخ هذه المغادلة الى الخلية C2 و اسحب نزولاً =IF(A2<>"",MID(SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))),1,FIND("|",SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))))-1)&" "&B2&" "&MID(SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))),FIND("|",SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))))+1,50),"") او هذه للاسماء المركبة =IF($A2="","",MID(SUBSTITUTE(A2," ","|",IF(LEN(A2)-LEN(SUBSTITUTE(A2," ",""))=1,1,2)),1,FIND("|",SUBSTITUTE(A2," ","|",IF(LEN(A2)-LEN(SUBSTITUTE(A2," ",""))=1,1,2)))-1)&" "&B2&" "&MID(SUBSTITUTE(A2," ","|",IF(LEN(A2)-LEN(SUBSTITUTE(A2," ",""))=1,1,2)),FIND("|",SUBSTITUTE(A2," ","|",IF(LEN(A2)-LEN(SUBSTITUTE(A2," ",""))=1,1,2)))+1,20)) وضع اسم الاب قبل الكنية.rar

جرب عذا الملف الذي لا يسمح لك بالاحطاء خطأ في التنسيق salim.rar

انسخ هذه المغادلة الى الخلية C2 و اسحب نزولاً =IF(A2<>"",MID(SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))),1,FIND("|",SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))))-1)&" "&B2&" "&MID(SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))),FIND("|",SUBSTITUTE(A2," ","|",LEN(A2)-LEN(SUBSTITUTE(A2," ",""))))+1,50),"")

بالنسبة للفرق يمكن ايجاد الفرق بين تاريخين باليوم والساعة والدقيقة والثانية حسب المعادلة التالية حيث B1 هي التاريخ الاحدث =INT(B1-A1)&" days " & TEXT(B1-A1,"\[hh]:\[mm]:\[ss]") اما الجمع فانا لا استطيع ان افهم كيف يمكن جمع تاريحين مثلاً ما الفائدة من جمع 11/2/2015 + 10/4/2006 يمكن جمع الوقت بين تاريخين باستعمال المعادلة التالية =TEXT(B1+A1,"\[hh]:\[mm]:\[ss]") حيث مثلا A1 = 22/05/2015 03:35:11 B1 = 22/05/2015 05:30:12

فقط استعمل هذه المغادلة =SUMIF($D$5:$D$20,"<0",$D$5:$D$20)

جرب هذا الملف عدم اظهار المكرر salim.rar

هذا لانك وضعت العلامة العشرية للنص كنقطة و نفس الشيء للارقام ليعمل الكود كما تريد يرجى فصل الاحرف بعلامة غير النقطة و سوف يتم تعديل الكود بعد ذلك يمكتك استبدال لكود ليصبح هكذا Sub extract_numbers() Dim mycol As New Collection Dim mycol1 As New Collection Dim mytext, mytext1 As String lr = Cells(Rows.Count, 1).End(3).Row For i = 2 To lr x = Application.WorksheetFunction.Trim(Range("a" & i).Value) On Error Resume Next For t = 1 To Len(x) y = Mid(x, t, 1) If IsNumeric(y) Or Asc(y) = 46 Then mycol.Add y mytext = mytext & y Else mycol1.Add y mytext1 = mytext1 & y End If Next If Asc(Right((mytext), 1)) = 46 Then Cells(i, 2) = Left(mytext, Len(mytext) - 1) Else Cells(i, 2) = mytext End If Cells(i, 3) = Left(mytext1, Len(mytext1) - 1) & Chr(46) & Right(mytext1, 1) mytext = "" mytext1 = "" Next End Sub

سيتم التعديل

تفضل اخي على 2003 (عفواً اخي احمد لم انتبه الى مشاركتك) extract_text_number.rar

جرب هذا الشيء extract_number.rar

هدية ممتازة رغم انه عندي ملاحظة عليها ارجو تقبلها اذا كان عدد الحروف في النص العربي اكبر من عدد الحروف في النص الاجبني لا تظهر النتائج الصحيحة(يكتفى بالنص الاجنبي) العلاج:استبدال هذا السطر Do While N < Len(TT1) بهذا Do While N < Len(TT1) Or N < Len(TT2)

نفضل اخي هذا مثال مرفق اما بالنسبة للكود يصبح هكذا (يجب ةضغ الكلمة المطلوبة في الخلية A1) Private Sub UserForm_Initialize() 'تعريف المتغير من النوع النصي Dim Word As String 'تعريف متغير من النوع عدد صحيح Dim I As Integer '[Label] تعيين عنوان لأداة الـ Label1.Caption = Cells(1, 1).Value 'حلقة تكرارية من الرقم 1 إلى طول السلسلة النصية للأداة For I = 1 To Len(Label1) 'يساوي قيمة المتغير نفسه زائد [Word] المتغير النصي المسمى 'حيث يتم استخراج حروف الكلمة [Mid] الحرف الذي يتم استخراجه باستخدام الدالة 'مع كل حلقة تكرارية يتم التعامل مع حرف واحد فقط في كل مرة 'بمثابة الضغط على إنتر للانتقال لسطر جديد [Chr(13)] زائد الدالة '[Vertical] بالتالي يتحقق الهدف من الكود وهو جعل النص يظهر بشكل رأسي Word = Word & Mid(Label1, I, 1) & Chr(13) 'الانتقال للحرف التالي Next I 'ليكون العنوان الجديد للأداة [Word] تعيين المتغير المسمى Label1 = Word End Sub Book1.rar

نفس الشيء لكن بالمعادلة التالية: =IF(ROWS($A$1:A1)>LEN($A$1),"",MID($A$1,ROWS($A$1:A1),1)) بالنسبة للكود ما رأيك اخي ياسر ان نجعل المستخدم يختار الكلمة بذاته من خلال هذا السطر مثلاً Label1.Caption = cells(1,1).value

اكثر من رائع و لكن كيف التعامل معه باللغة العربية اعنقد انه يجب استعمال Text Direction لهذا الغرض

يمكن استعمال هذا الكود و الكتابة في العامود H (الترتيب برده الاجنبية) Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If IsNumeric(Target.Value) And Target.Count = 1 And Target.Column = 8 Then Target.Offset(0, 1).Value = Target.Value Target.Offset(0, 1).NumberFormat = "#""" & Mid$("thstndrdthththththth", 1 - 2 * ((Target.Value) _ Mod 10) * (Abs((Target.Value) Mod 100 - 12) > 1), 2) & """" End If Application.EnableEvents = True End Sub