محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي مع تعديل التنسيقات بما يناسبك Sub TransferDataAndFormat() Dim WS As Worksheet, dest As Worksheet, ColArr As Variant Dim OnRng As Variant, lastRow As Long, n As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set WS = Sheets("DATA") Set dest = Sheets("Summary") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 8 Then Exit Sub OnRng = WS.Range("A8:I" & lastRow).Value dest.Range("A8").Resize(lastRow - 7, 9).Value = OnRng ColArr = Array(25, 23, 22, 13, 18, 16, 25, 30, 20) With dest .Columns.Font.Name = "Arial" .Columns.Font.Size = 14 For n = 1 To 9 Select Case n Case 1 .Columns(n).NumberFormat = "###0" Case 2 .Columns(n).NumberFormat = "#,##0" Case 3 .Columns(n).NumberFormat = "#,##0.00" Case 4 .Columns(n).NumberFormat = "0.00%" Case 5 .Columns(n).NumberFormat = "@" Case 6 .Columns(n).NumberFormat = "dd/mm/yyyy" Case 7 .Columns(n).NumberFormat = "$#,##0.00" Case 8 .Columns(n).NumberFormat = "0.00%" Case 9 .Columns(n).NumberFormat = "General" End Select .Columns(n).ColumnWidth = ColArr(n - 1) Next n End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub Book1.xlsm

إذا تم إدخال قيمة رقمية في الخلية C5 يقوم الكود بالبحث عن نفس الرقم في العمود الأول (A) في ورقة البيانات و تحديث التاريخ في العمود (T) يمكنك تعديله بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet, dest As Worksheet Dim tmp As Double, n As Long,cell As Range Set WS = ThisWorkbook.Sheets("الادخال") Set dest = ThisWorkbook.Sheets("البيانات") If Not Intersect(Target, WS.Range("C5")) Is Nothing Then tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then On Error Resume Next Set cell = dest.Range("A2:A" & _ dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole) On Error GoTo 0 If Not cell Is Nothing Then cell.Offset(0, 19).Value = Date End If End If End If End Sub 1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub TransferDate() Dim tmp As Double, n As Long Dim WS As Worksheet, dest As Worksheet Set WS = Sheets("الادخال") Set dest = Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then n = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row + 1 dest.Cells(n, 1).Value = tmp dest.Cells(n, 20).Value = Date End If End Sub للترحيل الى نفس الخلايا بشكل دائم Sub TransferDateFix() Dim tmp As Double Dim WS As Worksheet, dest As Worksheet Set WS = Sheets("الادخال") Set dest = Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then dest.Range("A2").Value = tmp dest.Range("T2").Value = Date End If End Sub معادلة الرقم كتابة + ترحيل رقم الادخال الى شيت اخر استنادا لرقم الادخال.xlsb

نعم أظن أن نسخة 2013 تشتغل على Windows 7 Service Pack 1 وما فوق

ادن حاول على الأقل الترقية لنسخة 2010 لان الملف ليس به أي مشكلة

جرب تحميل نسخة أحدث https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file

قم بتحميل الملف مرة أخرى بعد التعديل ووافينا بالنتيجة أعتقد أن المشكلة لديك ليس في نسخة الأوفيس حيث أن جميع الدوال والميزات المستخدمة في الكود مدعومة في Excel 2007

شكل بياناتك غير مفهوم يصعب التعامل معه في ظل غياب نمودج أو عينة لشكل النتائج المتوقعة ممكن توضح لنا كيف حصلت مثلا على هده النتائج

جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("N5")) Is Nothing Then Dim a As Variant, i As Long, k As Long, schoolName As String Dim n() As Variant, cnt As Long, count As Long, lr As Long, r As Long Dim WS As Worksheet: Set WS = Sheets("اسماء العاملين ") Dim dest As Worksheet: Set dest = Sheets("طباعة كشف المدرسة") schoolName = Me.Range("N5").Value If schoolName = "" Then Exit Sub a = WS.Range("A7:F" & WS.Cells(WS.Rows.count, "A").End(xlUp).Row).Value cnt = 0 For i = 1 To UBound(a, 1) If a(i, 6) = schoolName Then cnt = cnt + 1 End If Next i If cnt = 0 Then MsgBox "إسم المدرسة غير موجود في قاعدة البيانات", vbExclamation Exit Sub End If On Error Resume Next lr = dest.Columns("A:I").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If lr >= 9 Then dest.Range("A9:E" & lr).ClearContents dest.Range("I9:I" & lr).ClearContents End If ReDim n(1 To cnt, 1 To 5) k = 1 For i = 1 To UBound(a, 1) If a(i, 6) = schoolName Then n(k, 1) = k n(k, 2) = a(i, 2): n(k, 3) = a(i, 3) n(k, 4) = a(i, 4): n(k, 5) = a(i, 5) k = k + 1 End If Next i With dest .Cells(9, 1).Resize(cnt, 5).Value = n .Cells(9, 9).Resize(cnt, 1).Value = schoolName count = Application.WorksheetFunction.CountA(.Range("B9:B" & _ .Cells(.Rows.count, "B").End(xlUp).Row)) .[H4].Value = count End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End If End Sub سرى الشهادة الاعدادية.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته طلبك غير واضح أخي الكريم

أخي @mohamed.youssef للعلم إحتمال 90% من حصولك على إجابة صحيحة تكمن في طريقة طرح طلبك الصيغة التي قمت بطرح بها طلبك في أول مشاركة (التعديل وربط الألوان.... ) كيف نفهم نحن أنك تريد جلب التواريخ من إلى إذن الكود المقترح يقوم بجلب القيم الفريدة من عمود A ونسخ القيم من عمود G بشرط التاريخ وعند وجود تواريخ مكررة يتم دمج القيم المتعلقة بها في خلية واحدة مثلا 156-456..... وهكذا أما طلبك الحالي التاريخ من إلى يرجى إرفاق عينة لشكل البيانات المتوقعة للتوضيح وان شاء الله سوف نحاول مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub ItemsRollKgmsKnt() Dim d1 As Object, d2 As Object Dim OnRng() As Variant, a, g, d As Variant Dim tmp As Integer, n As Integer, mx As Integer Dim WS As Worksheet: Set WS = Sheets("KN") Set d1 = CreateObject("Scripting.Dictionary") Set d2 = CreateObject("Scripting.Dictionary") a = WS.Range("A2:A" & WS.[A65000].End(xlUp).Row).Value g = WS.Range("G2:G" & WS.[A65000].End(xlUp).Row).Value d = WS.Range("D2:D" & WS.[A65000].End(xlUp).Row).Value For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1 End If Next i mx = 31 ReDim OnRng(1 To d1.Count, 1 To mx + 1) For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then n = d1(a(i, 1)) tmp = Day(CDate(d(i, 1))) If tmp >= 1 And tmp <= 31 Then OnRng(n, 1) = a(i, 1) If OnRng(n, tmp + 1) = "" Then OnRng(n, tmp + 1) = g(i, 1) Else OnRng(n, tmp + 1) = OnRng(n, tmp + 1) & "-" & g(i, 1) End If End If End If Next i With Sheets("MM") .Range("A2").Resize(d1.Count, mx + 1).Value = OnRng .Columns.AutoFit End With End Sub KNTPROD V1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بما أنك تستخدم الأكواد على الملف أعتقد أنه بإمكانك ربط الكود بأي شكل وتقوم بوضعه فوق الصورة عادي نفس الفكرة المقترحة من الأخ @أبومروان بواسطة الأكواد مع إمكانية تحديد إسم الصورة والتعليق المرغوب إظهاره .يمكنك إظافة أي عدد من الأشكال وتعديل النطاقات بما يتناسب مع إحتياجاتك wor-v2.xlsm

بما أنك لم تجب عن سؤالي إليك طريقة أخرى ستقوم بإظافة عنصر جديد بإسم Line لإستخراج رقم صف المحدد عند الإختيار من عناصر الكومبوبوكس وإعتمادا عليه سنقوم بتعديل وحدف الصفوف Private Sub SearchData() Dim fnd As Range Dim ColA As String, ColB As String, ColC As String Dim criteria As Range, found As Boolean Dim rowNum As Long ColA = Me.ComboBox1.Value ColB = Me.ComboBox2.Value ColC = Me.ComboBox3.Value If Len(ColA) = 0 Then Exit Sub Set criteria = WS.Range("A4:C" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) found = False For Each fnd In criteria.Rows If fnd.Cells(1, 1).Value = ColA And _ (ColB = "" Or Format(fnd.Cells(1, 2).Value, "dd-mmm") = ColB) And _ (ColC = "" Or fnd.Cells(1, 3).Value = ColC) Then For i = 1 To 62 Me.Controls("TextBox" & i).Value = fnd.Cells(1, i).Value Next i rowNum = fnd.Row found = True Exit For End If Next fnd If Not found Then ClearTextBoxes Me.Line.Value = "" Else Me.Line.Value = rowNum End If End Sub Private Sub CommandButton2_Click() Dim r As Integer, n As Variant Dim i As Integer, X As Integer Dim rowNum As Long, fnd As Range If IsNumeric(Me.Line.Value) Then rowNum = CLng(Me.Line.Value) Else MsgBox " يرجى تحديدالبيانات المرغوب تعديلها", vbExclamation Exit Sub End If If rowNum < 5 Then: Exit Sub If SaisieText(1, 2) Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد") If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Cells(rowNum, 1) For i = 1 To 62 On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 If IsDate(n) Then fnd.Offset(0, i - 1).Value = CDate(n) Else fnd.Offset(0, i - 1).Value = n End If Next i Call UpdateNum(WS) Clear_TextBox UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم التعديل بنجاح", vbInformation End Sub Private Function SaisieText(startIdx As Integer, endIdx As Integer) As Boolean Dim i As Integer, X As Integer Dim arr() As String, TexArr As String For i = startIdx To endIdx If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(X) arr(X) = TexArr X = X + 1 End If Next i If X > 0 Then MsgBox ": يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation SaisieText = True Else SaisieText = False End If End Function ترحيل مع كمبوبوكس البحث بحقلين V3.xlsm

ليس هناك اي خطأ في الكود لاكنني أعتقد اخي أنك لم تنتبه لما جاء في المشاركة السابقة بمعنى عن محاولة التعديل او الحدف يجب تطابق قيم عناصر التيكست بوكس 1-2-3 مع بيانات الصف المرغوب تنفيد الاجراء عليه وهدا بسبب البيانات المكررة 1) السؤال هل انت بحاجة لتعديل رقم المسلسل والتاريخ 2) في وضعنا الحالي لنفترض ان شكل البيانات لدينا بهدا الشكل ولديك رغبة بتعديل او حدف الصف رقم 2 مثلا كيف يمكننا تحديده والقيم مكررة على عمود المسلسل والتاريخ م التاريخ رقم الموظف المنصب الوظيفي تاريخ استلام المنصب الشهادة بعد التعيين 1 2 1 01-Oct 1 المنصب الوظيفي 1 استلام العمل1 شهادة 1 شهادة 2 1 01-Oct 2 المنصب الوظيفي 2 استلام العمل2 شهادة 2 شهادة 3 1 01-Oct 3 المنصب الوظيفي 3 استلام العمل3 شهادة 3 شهادة 4 3 01-Oct 1 المنصب الوظيفي 4 استلام العمل4 شهادة 4 شهادة 5 3 01-Oct 2 المنصب الوظيفي 5 استلام العمل5 شهادة 5 شهادة 6

أخي @ehabaf2 أظن اننا بحاجة لإفراغ اليوزرفورم من جميع الأكواد السابقة وإعادة إظافة أكواد جديدة لتتناسب مع طلبك 1) تعديل أعمدة تعبئة عناصر الكومبوبوكس 2) تعديل كود الترحيل للحصول على تسلسل عمود C (رقم الموظف) بداية من رقم 1 للقيمة الفريدة مع تسلسلها عند تكرار نفس المسلسل ونفس التاريخ 3) تعديل كود تحديث البيانات بحيث يتم تعديل الصف بشرط تطابق المسلسل والتاريخ ورقم الموظف (TEXTBOX1-TEXTBOX2-TEXTBOX3) 4) نفس الفكرة على كود الحدف تفاديا لحدف أي بيانات لا تتطابق مع القيم المختارة بالعناصر خاصة انها مكررة (TEXTBOX1-TEXTBOX2-TEXTBOX3) وضمان إعادة التسلسل للشكل المطلوب كان بامكاني الإكتفاء بنشر كود الترحيل فقط بعد إظافة التسلسل المطلوب لاكنك ستواجه مشاكل عند محاولة الحدف أو التعديل وسنظطر الى إعادة فتح موضوع جديد 😂 لاكن ولا يهمك بالنسبة لتعبئة عناصر الكومبوبوكس تم تعديلها على حسب طلبك كما في الصورة اسفله كود الترحيل بعد إظافة تسلسل عمود C بالشروط المدكورة Private Sub CommandButton1_Click() 'ترحيـل البيانات Dim i As Integer, lastRow As Long, choose As Integer Dim x As Integer, arr() As String, TexArr As String For i = 1 To 3 If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(x) arr(x) = TexArr x = x + 1 End If Next i If x > 0 Then MsgBox "يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation Exit Sub End If choose = MsgBox("ترحيـل البيانات؟", vbYesNo, "تأكيـــد") If choose <> vbYes Then Exit Sub Application.ScreenUpdating = False lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1 For i = 1 To 62 If i <> 3 Then On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 With ws.Cells(lastRow, i) If IsDate(n) Then .Value = CDate(n) Else .Value = n End If End With End If Next i Call UpdateNum(ws) For i = 1 To 62: Me.Controls("TextBox" & i).Value = "": Next i For i = 1 To 3: Me.Controls("ComboBox" & i).Value = "": Next i UserForm_Initialize Application.ScreenUpdating = True End Sub الدالة التالية لتسلسل عمود رقم الموظف سنقوم بإستدعائها سواءا عند الترحيل أو الحدف وكدالك التعديل لضمان الحفاظ على التسلسل الصحيح عند كل إجراء Function UpdateNum(ws As Worksheet) As Boolean On Error GoTo ErrorHandler Dim lastRow As Long, OnRng As Range Dim n() As Variant, ar() As Variant Dim src As Long, tmp As String Dim Dict As Object Set Dict = CreateObject("Scripting.Dictionary") lastRow = ws.Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set OnRng = ws.Range("A5:B" & lastRow) ar = OnRng.Value2 ReDim n(1 To UBound(ar, 1), 1 To 1) For i = 1 To UBound(ar, 1) If ar(i, 1) <> "" And ar(i, 2) <> "" Then tmp = ar(i, 1) & "|" & ar(i, 2) If Not Dict.Exists(tmp) Then src = 1 Dict.Add tmp, src Else src = Dict(tmp) + 1 Dict(tmp) = src End If n(i, 1) = src Else n(i, 1) = "" End If Next i ws.Range("C5").Resize(UBound(n, 1), 1).Value = n UpdateNum = True Exit Function ErrorHandler: UpdateNum = False End Function الملف المرفق يتضمن تعديل جميع الاكواد المدكورة سابقا ترحيل مع كمبوبوكس البحث بحقلين V2.xlsm

تمام ممكن نعدلها لاكن كود الترحيل يتضمن تسلسل للبيانات في عمود A ما يمنع تكرار القيم به هل ستقوم بحدفه وادخال التسلسل يدويا

هدا ما تم الاشتغال عليه فعلا بحيث يكون البحث ديناميكيا بين جميع العناصر 1-2-3 بمعنى عند إختيار قيمة كومبوبوكس 1 يتم تعبئة كومبوبوكس 2 بالقيم المتاحة فقط وعند الإختيار من 2 يتم تعبئة كومبوبوكس 3 بالقيم المتاحة يشرط 1 و 2 فقط لاحظ الصورة المتحركة مثلا عند اختيار رقم التسلسل 4 طلبك غير واضح هل تقصد تسلسل للبيانات عند الترحيل او مادا

هل من الممكن إرفاق عينة للنتائج المتوقعة يدويا للتوضيح أكثر

العقو اخي @tahar

وعليكم السلام ورحمة الله تعالى وبركاته 1) بما أن الملف لا يتضمن معادلات حاول تجربة تقليل حجم الملف عبر إزالة الصفوف أو الأعمدة الفارغة وأي بيانات غير ضرورية مع التأكد من عدم وجود تنسيقات زائدة (مثل الألوان أو أنماط الخلايا) الغير مستخدمة فهي تؤثر على سرعة التحميل 2) في حالة وجود كود VBA مثلا في حدث ورقة الإدخال يمكن أن يكون سببا في عملية البطئ التي تواجهك خاصة إذا كان الكود يقوم بعمليات معقدة أو يتضمن حلقات 3) قم بحفظ الملف بصيغة xlsb حيث إن هذه الصيغة عادة ما تكون أخف بالتوفيق.......

Book1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته ترحيل مع كمبوبوكس البحث بحقلين).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب إحدى المعادلات التالية =IFERROR(INDEX(الرئيسة!B:B, MATCH(H6, الرئيسة!A:A, 0)),"") او =IFERROR(VLOOKUP(H6,الرئيسة!A:B, 2, FALSE),"") او استخدام الأكواد Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$6" Then Dim tmp As String, Rng As Range, References As Variant tmp = Target.Value Set Rng = Me.Range("I6") If tmp = "" Then: Rng.Value = "": Exit Sub On Error Resume Next References = Application.WorksheetFunction.VLookup(tmp, _ Sheets("الرئيسة").Range("A:B"), 2, False) On Error GoTo 0 If Not IsError(References) Then Rng.Value = References End If End If End Sub Book1.xlsx