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

استاذنا ومعلمنا الاستاذ/موسى تمام هو المطلوب جزاك الله خير وجعله فى ميزان الحسنات وبارك الله فى اعمالك الجميلة التى عن نفسى تطربنى وتشجينى

وعليكم السلام ورحمة الله تعالى وبركاته ادا كان هدا ما تقصده جرب هدا =IFERROR(TEXT(DATE(2000+LEFT(B2,2),MID(B2,3,2),RIGHT(B2,2)),"DD/MM/YYYY"),"") او Option Explicit Sub ConvertDate() Dim lr As Long, r As Long, xDate As String, n As String Dim scWS As Worksheet: Set scWS = Sheets("Sheet1") lr = scWS.Cells(scWS.Rows.Count, "B").End(xlUp).Row For r = 2 To lr xDate = scWS.Cells(r, "B").Value If xDate <> "" Then n = Format(DateSerial(2000 + Left(xDate, 2), _ Mid(xDate, 3, 2), _ Right(xDate, 2)), "dd/mm/yyyy") scWS.Cells(r, "D").Value = n End If Next r End Sub New Microsoft Excel Worksheet.xlsx

شكرا اخي الحبيب ابو خليك اخوتي البرنامج هو الديلفي Delphi وانا استخدم النسخة 11, لمن يريد ان يستخذم النسخة هنا وهي غير مجانية , تجد مع النسخة الكراك و التفعيل https://downloaddevtools.com/en/product/1/free-download-embarcadero-rad-studio-10-4-sydney ولكي لا اطول عليكم قمت بتصوير كل حركة قمت بها اثناء استعمال البرنامج , و للشرح بقية , ولكم مني اجمل شكر وهذه هي النتيجة في الصورة

وعليكم السلام ورحمة الله وبركاته يمكن ينفع جرب النموذج في قاعدة موجودة عندك حتى ترى المعيار يتحرك حجم القاعدة.accdb

نعم اخي @hanykassem نظرا للمثال المرفق هناك بعض الإحتمالات الواردة في حالة كان هناك تكرار لنفس القيم كما هو موضح في الصورة أدناه Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim i As Long, ling As Long, lastRow As Long, tmp As String, kayB As String, kayC As String, _ j As Variant, a As Object, r As Object Set a = CreateObject("Scripting.Dictionary"): Set r = CreateObject("Scripting.Dictionary") If Not Intersect(Target, WS.Range("A4:C" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False With WS .Range("I3:K" & .Rows.Count).ClearContents lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ling = 3 For i = 4 To lastRow tmp = .Cells(i, 1).value kayB = .Cells(i, 2).value kayC = .Cells(i, 3).value If tmp <> "" Then If kayB <> "" Then a(tmp) = IIf(a.Exists(tmp), a(tmp) & " , " & kayB, kayB) If kayC <> "" Then r(tmp) = IIf(r.Exists(tmp), r(tmp) & " , " & kayC, kayC) End If Next i For Each j In a.Keys .Cells(ling, 9).value = j .Cells(ling, 10).value = a(j) .Cells(ling, 11).value = r(j) ling = ling + 1 Next j .Columns("j:K").AutoFit End With Application.ScreenUpdating = True End If End Sub لحدف التكرارات قم بتعديل الصف التالي If tmp <> "" Then If kayB <> "" Then a(tmp) = IIf(a.Exists(tmp), a(tmp) & " , " & kayB, kayB) If kayC <> "" Then r(tmp) = IIf(r.Exists(tmp), r(tmp) & " , " & kayC, kayC) End If إلى If tmp <> "" Then If kayB <> "" Then If Not a.Exists(tmp) Then a.Add tmp, _ kayB Else If InStr(1, a(tmp), kayB) = 0 Then a(tmp) = a(tmp) & " , " & kayB If kayC <> "" Then If Not r.Exists(tmp) Then r.Add tmp, _ kayC Else If InStr(1, r(tmp), kayC) = 0 Then r(tmp) = r(tmp) & " , " & kayC End If TEST CODE 2.xlsb

يمكنك تعديل كود عرض الأعمدة بترتيب العناصر على الشكل التالي Private Sub ContrArr(tmp As Long) Dim controls As Variant, columns As Variant, i As Integer controls = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") columns = Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12) If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(controls) To UBound(controls) Me.controls(controls(i)).Text = WS.Cells(tmp, columns(i)).Value Next i tblUpdate tmp End If End Sub البحث والتنقل.rar

وعليكم السلام ورحمة الله وبركاته 🙂 عملت شيء مشابه لهذا سابقا .. فقط يمكن تعديله ليتوافق مع الحاجة 🙂 ‏‏Meter -Moosak _ Final.accdb

كود للفرز بمعيارين ولكن به اضافه مفيده وهي ازاله المسافات من بين الاسماء مما تعطي فرزا دقيقا للمحترم الغالي ياسر العربي Dim lr As Long lr = Range("E" & Rows.Count).End(xlUp).Row For Each Cell In ActiveSheet.Range("E7:E" & lr) Cell.Value = Application.WorksheetFunction.Trim(Cell.Value) Next Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo End Sub

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة كيف اربط الصور بالقائمه المنسدله تم ارفاق كود الحل من الفاضل ا / أبوعبد الله مرفق الملف بيانات الموظفين-1.rar و لا تنسونا من صالح الدعاء تحياتى