رجب جاويش

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

أخى الفاضل /office 2003 جزاك الله كل خير على هذه الكلمات الطيبة بالنسبة للأسماء المركبة يمكن كتابتها بدون مسافة مثل (عبدالله ) بدلا من ( عبد الله ) لأن هذا الكود يفصل الكلمات اعتمادا على المسافة الموجودة بينها

أخى الفاضل / أحمد البحيرى مرحبا بعودتك مرة أخرى ونورت المنتدى هذه فكرة فى البداية وجارى تطويرها

أخى ابراهيم تفضل الملف وبه الكود والملف موجود أيضا فى المشاركة رقم 7 كود تسلسل.rar

أخى الفاضل / أبو أنس حاجب بعد التحية جرب الكود التالى Sub ragab() For Each cl In [A5:A2000] If cl.Offset(0, 20) = 0 Then cl.Resize(1, 19).ClearContents End If Next End Sub مسح بيانات مدى بناءا علي شرط.rar

أخى ابراهيم لا داعى لتكرار أجزاء الكود كاملة ولكن يكفى فقط هذا الجزء For Each cl In Range("G2:G" &amp;amp; LR) If cl <> "" Then cl.Offset(0, 2) = WorksheetFunction.Max(Range("I2:I" &amp;amp; cl.Row)) + 1 End If Next كما يتضح لك من المرفق الموجود فى المشاركة السابقة مع مرعاة عدم الترقيم فى الخلايا المقابلة للخلايا الفارغة من العمود G حسب طلبك

شكرا جزيلا لك أخى الحبيب محمود جزاك الله كل خير

تفضل أخى ابراهيم تم عمل التسلسل الجديد ضمن الكود السابق كود تسلسل.rar

أخى ابراهيم ألف شكر أخى الفاضل على هذه الكلمات الطيبة وجزاك الله كل خير

أخى ابراهيم الجزء If Cells(i, 7) = cl Then Cells(i, 8) = cl.Offset(0, 1) يعمل على إعطاء الأرقام المتشابهة نفس التسلسل أما بالنسبة للتسلسل الذى تريده فى العمود التاسع أريد أن أستفسر عن وضع الارقام المتشابهة هل تاخذ نفس الرقم أم لا

أخى الفاضل / سعد عابد شكرا جزيلا أخى الفاضل على هذا المرور العطر وجزاك الله كل خير

أخى الحبيب / عيد مصطفى جزالك الله كل خير اخى الحبيب على هذا المرور العطر والكلمات الطيبة تقبل أرق وأجمل تحياتى

أستاذى الحبيب / عبد الله باقشير زادك الله علما وتواضعا فما رأيت مثل تواضعك وأسلوبك الراقى فى تعليم تلاميذك أدامك الله لنا معلما ومبدعا

تفضل أخى ss1.rar

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

أخى الفاضل / أبو ردينة شكرا جزيلا أخى الفاضل وجزاك الله كل خير

ثانيا باستخدام دالة معرفة Function RG_split(cl As Range, v As Integer) RG_split = Split(cl, " ")(v - 1) End Function طريقة استخدام الدالة =RG_split(A2;1) لفصل الاسم الأول نضع الرقم 1 ولفصل الاسم الثانى نضع الرقم 2 وهكذا كما فى الملف المرفق فى النهاية كل الشكر والإمتنان لأستاذى الحبيب / عبد الله باقشير الذى أتعلم منه الكثير والكثير لأنه الكنز الذى أنهل منه هذه المعلومات دالة معرفة لفصل الأسماء.rar

السلام عليكم ورحمة الله وبركاته هذه بعض المحاولات فى تجزئة الأسماء فى عدة خلايا متجاورة وهى محاولات متواضعة خاصة مع وجود دوال وطرق كثيرة لفصل الأسماء وتجزئتها وخصوصا الدالة المعرفة الرائعة لأستاذنا الكبير / عبد الله باقشير يتم الفصل اعتمادا على وجود مسافة فاصلة " " بين الأسماء فى البداية أولا : باستخدام كود Sub ragab() Dim newsplit As Variant Dim x As Integer, cl As Range Dim Row_cl As Integer, col_cl As Integer '============================================ LR = [A1000].End(xlUp).Row '============================================ For Each cl In Range("A2:A" & LR) Row_cl = cl.Row col_cl = cl.Column newsplit = Split(cl, " ") x = UBound(newsplit) Range(Cells(Row_cl, col_cl + 1), Cells(Row_cl, col_cl + 1 + x)).Value = newsplit Next End Sub تقسيم الإسم.rar

الأخ الفاضل / matef يمكنك مراجعة الحل على الرابط التالى http://www.officena.net/ib/index.php?showtopic=43870&st=0&gopid=254642&#entry254642

أخى الفاضل يمكنك استعمال الدالة التالية =ROUND(D2;0) وسحبها للأسفل

أخى يوسف السلام عليكم هذا الكود يظلل المكرر فى العمودين Sub ragab() LR1 = [B10000].End(xlUp).Row LR2 = [H10000].End(xlUp).Row '================================================ Range("B2:B" & LR1).Interior.ColorIndex = xlNone Range("H2:H" & LR1).Interior.ColorIndex = xlNone '================================================ For Each cl In Range("B2:B" & LR1) For Each cll In Range("H2:H" & LR2) If cl <> "" And cl = cll Then cl.Interior.ColorIndex = 3 cll.Interior.ColorIndex = 3 End If Next Next End Sub

سيكون بالشكل التالى Private Sub UserForm_Activate() Dim cl As Range, x As Integer x = Application.WorksheetFunction.Count(Range("List")) If x > 1 Then Me.ComboBox1.Column = Range("list2").Value Else For Each cl In Range("List") If cl <> "" Then Me.ComboBox1.Value = cl End If Next End If End Sub COMB22222.rar

أخى ابراهيم جرب هذا الكود Sub ragab() LR = [G10000].End(xlUp).Row Set Rng = Range("G2:G" & LR) Range("H2:H1000") = "" x = 2 For Each cl In Range("G2:G" & LR) If cl = "" Then x = cl.Row If WorksheetFunction.CountIf(Range("G2:G" & cl.Row), cl) = 1 Then cl.Offset(0, 1) = WorksheetFunction.Max(Range(Cells(x, "H"), Cells(cl.Row, "H"))) + 1 End If If WorksheetFunction.CountIf(Rng, cl) > 1 Then For i = 3 To LR If Cells(i, 7) = cl Then Cells(i, 8) = cl.Offset(0, 1) End If Next End If Next Set Rng = Nothing End Sub كود تسلسل.rar

تفضل أخى ابراهيم COMB22222.rar

أخى الفاضل فى السطر التالى cl.Resize(1, 2).Copy الرقم 2 هو عدد الخلايا التى تريد نسخها من الصف يمكنك تغيير الرقم كما تشاء Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "1" Then sh.Range("a1:iv1000").ClearContents End If Next LR = Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Range("A1:A" & LR) x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If cl.Resize(1, 2).Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Range("A1") = "حرف" & " " & cl Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("1").Select Application.ScreenUpdating = False End Sub 111بعد تعديل الطلب.rar