نجوم المشاركات

تفضل اخي الفضل Private Sub TextBox1_Change() If Val(TextBox1.Value) > 0 Then TextBox1.BackColor = RGB(255, 0, 0) ' ÇáÃÍãÑ: RGB(255, 0, 0) Else TextBox1.BackColor = RGB(255, 255, 255) ' ÇáÃÈíÖ: RGB(255, 255, 255) End If End Sub

تفضل اخي الكود طويل نوعا ما لاكنه سريع Sub Create_Worksheets() Dim desWS As Worksheet, srcWS As Worksheet Dim rCrit As Range, rngFilter As Variant Dim Irow As Long, LastCol As Long Dim rgData As Range, destRng As Range Dim Dic As Object, dictKey As String, Cpt As Variant Dim Destination As Range, i As Long Set desWS = Worksheets("البيانات") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next With desWS Irow = .Cells(Rows.Count, "D").End(xlUp).Row LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 2 Set rCrit = .Range("C1:E" & Irow): rngFilter = rCrit.Columns(2) ' نطاق المعايير Set rgData = .Cells(1, LastCol): rgData.Value = .[D1] Set rgData = .Cells(1, LastCol).Resize(2) End With ' الحصول على مجموعة الحروف الفريدة - الحرف الأول من الاسم Set Dic = CreateObject("Scripting.dictionary") Dic.CompareMode = vbTextCompare For i = 2 To UBound(rngFilter) dictKey = Left(rngFilter(i, 1), 1) If Not Dic.exists(dictKey) Then Dic(dictKey) = "" End If Next i ' رمز اظافي للتعامل مع حرف الالف '(ا,أ,إ,آ) & Unicode & وتجميعه والذي يمكن أن يكون 4 أحرف مختلفة Dim a As Variant, b As Boolean, Clé() As String, j As Long a = Array(1570, 1571, 1573, 1575) ReDim Clé(1 To UBound(a) + 1) For i = 0 To UBound(a) dictKey = ChrW(a(i)) If Dic.exists(dictKey) Then b = True Dic.Remove dictKey End If j = j + 1 Clé(j) = dictKey & "*" Next i If b Then dictKey = Replace(Join(Clé, ","), "*", "") Dic(dictKey) = "" End If '*مراجعة المعرفات مع إنشاء أو تحديث ورقة جديدة للمجموعة الحرفية *** For Each Cpt In Dic.keys ' ***التحقق من وجود ورقة العمل مسبقا*** If Evaluate("ISREF('" & "حرف" & "-" & Cpt & "'!A1)") Then Set srcWS = Worksheets(Cpt) srcWS.UsedRange.Clear Else Set srcWS = Worksheets.Add(After:=Sheets(Sheets.Count)) srcWS.Name = "حرف" & "-" & Cpt: Set Destination = srcWS.[A1] End If '** تصفية If Len(Cpt) > 1 Then rgData.Cells(2).Resize(UBound(Clé)) = Application.Transpose(Clé) Set rgData = rgData.CurrentRegion Else rgData.Offset(1).ClearContents rgData.Cells(2) = Cpt & "*" Set rgData = rgData.CurrentRegion End If rCrit.AdvancedFilter xlFilterCopy, rgData, Destination '***تنسيق عرض عمود المصدر*** rCrit.EntireColumn.Copy srcWS.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths [A1].Select: ActiveSheet.DisplayRightToLeft = True Dim nCount As Integer, shName As Range, lastrow As Long '***(ازالة التكرار في حالة وجوده (على الاوراق الجديدة *** lastrow = srcWS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row 'الاعمدة arr = [{1,2,3}] srcWS.Range(Cells(1, 1), srcWS.Cells(lastrow, 3)).RemoveDuplicates arr(1), Header:=xlNo Next Cpt 'اظافة الارتباط التشعبي desWS.Columns("J:G").Clear: desWS.UsedRange.Hyperlinks.Delete j = 2 For Each WS In ThisWorkbook.Worksheets If WS.Name Like "*ح*" Then nCount = nCount + 1 ActiveWorkbook.Sheets("البيانات").Hyperlinks.Add _ Anchor:=ActiveWorkbook.Sheets("البيانات").Cells(j, 10), Address:="", SubAddress:="'" & WS.Name & "'!A1", _ TextToDisplay:=WS.Name Worksheets(WS.Name).Hyperlinks.Add Anchor:=Worksheets(WS.Name).[E2], Address:="", _ SubAddress:="'" & desWS.Name & "'" & "!A1", TextToDisplay:="ورقةالبيانات" j = j + 1 End If Next WS ' استخراج اسماء المجموعات الحرفية Set shName = desWS.Range("j2", desWS.Range("j" & desWS.Rows.Count).End(xlUp)) For Each c In shName If WorksheetFunction.CountIf(shName, c) >= 1 Then If InStr(1, s, c) = 0 Then s = s & " ** " & c Next desWS.Activate .DisplayAlerts = True .ScreenUpdating = True End With resultat = IIf(s <> "", vbLf & Mid(s, 2), "") MsgBox resultat, vbInformation, "تم تحديث" & " : " & nCount & " " & "مجموعة بنجاح" End Sub ترحيل الاسماء حسب الاحرف الى شيتات V2.xlsm

Private Sub TextBox1_Change() If Val(TextBox1.Value) > 0 Then TextBox1.ForeColor = RGB(255, 0, 0) ' الأحمر: RGB(255, 0, 0) Else TextBox1.ForeColor = RGB(0, 0, 0) ' الأسود: RGB(0, 0, 0) End If End Sub ^ vdf

اريد برنامج يسجل عهد كل موظف

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

Thanks for the quick response شكرا على الاستجابة السريعة

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل Nationalities جدول الجنسيات.xlsx

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

ولك بالمثل اخي الكريم يسعدنا أننا استطعنا مساعدتك سوف اقوم بتنفيذ طلبك عن قريب بإذن الله

السلام عليكم كل اسم يبدأ بحرف أ يتم دمجها في شيت واحد وكذلك باقي الاسماء ، فمثلا حرف (ب) كل اسم يبدأ بحرف الباء يدمج في شيت واحد تسلم ممنون

حياكم الله جميعا ... عمل جميل وفقكم الله لكل خير..

أرسلت لك رقم تليفوني للتواصل

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة الملف لاحظت انه هناك أسماء مختلفة تبدأ بحرف الألف مثلا . إبراهيم ، أدهم ، آياد ، أحمد ....... احسان بمعنى القاسم المشترك بينهم حرف الألف هل يتم دمج هذه الأسماء في نفس المجموعة أو انشاء لكل مجموعة حرفية ورقة مستقلة او تجاهل الأمر وإعادة تصحيح وتوحيد نوع الكتابة من طرفك