محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته رغم انني أعتقد أنك يجب عليك اتخاد مزيدا من الاجراءات لحماية الملف لاكن سأحاول في الكود التالي تنفيد طلبك إعتمادا على تخزين وقت الدخول الخاطئ في ورقة مخفية تمت إظافتها للملف بإسم Sheet1 يمكنك تعديلها بما يناسبك (يمكنك نخزينه في اي ورقة موجودة مسبقا على المصنف) فرغ نمودج المستخدم الخاص بك من جميع الأكواد السابقة وقم بنسخ هدا Private Sub CommandButton1_Click() Dim WS As Worksheet Dim Utilisateu As String, Passe As String Dim key As Date Static Compter As Integer Set WS = ThisWorkbook.Sheets("Sheet1") key = WS.[A1] '**** تم تحديد قفل الملف 30 ثانية للتجربة**** Clé = Now + TimeValue("00:00:30") '******************************************** 'Clé = Now + TimeValue("00:30:00") ' تحديد وقت القفل بعد 30 دقيقة WS.Visible = xlSheetVeryHidden Utilisateu = TextBox1.Value 'اسم المستخدم Passe = TextBox2.Value ' الرقم السري ' تغيير لون خلفية مربع كلمة المرور عند الإدخال الخاطئ TextBox2.BackColor = RGB(255, 255, 255) ' اللون الافتراضي If key > Now Then MsgBox "الملف مغلق يرجى المحاولة مرة أخرى بعد " & _ Format(key - Now, "hh:mm:ss") & ".", vbExclamation, "تعذر الدخول للملف" ThisWorkbook.Save ThisWorkbook.Close False Exit Sub End If If Utilisateu = "admin" And Passe = "1234" Then Compter = 0 MsgBox Utilisateu & " مرحبًــا بك", vbInformation, "ترحيب" Application.Visible = True Unload Me Else Compter = Compter + 1 TextBox2.BackColor = RGB(255, 0, 0) ' تغيير اللون إلى الأحمر عند الإدخال الخاطئ If Compter >= 3 Then ' تحديد عدد المحاولات المسموح بها key = Clé: WS.[A1] = key MsgBox "تم قفل الملف لمدة 30 دقيقة", vbCritical, "تعذر الدخول للملف" Compter = 0 ThisWorkbook.Save ThisWorkbook.Close False Exit Sub Else MsgBox "بيانات الدخول غير صحيحة. محاولة " & _ Compter & " من 3", vbExclamation, "إنتباه" End If End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Dim kay As Date On Error Resume Next kay = Sheets("Sheet1").Range("A1").Value On Error GoTo 0 If kay > Now Then MsgBox "الملف مغلق يرجى المحاولة مرة أخرى بعد " & _ Format(kay - Now, "hh:mm:ss") & ".", vbExclamation, "تعذر الدخول للملف" ThisWorkbook.Save ThisWorkbook.Close False Else Application.Visible = False UserForm1.Show End If End Sub بالتوفيق.. دخول بعد ساعة.xlsm

بطريقة أخرى Sub Advanced_REs_Data() Dim lr As Long, lr2 As Long, r As Long Dim f As Worksheet, WS As Worksheet Set f = Sheets("Data"): Set WS = Sheets("CAll") lr = f.Cells(Rows.Count, 2).End(xlUp).Row lr2 = WS.Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr f.Range("E" & r).Value = IIf(IsError(Application.Match(f.Cells(r, 2).Value, _ WS.Range("A2:A" & lr2), 0)), f.Range("E" & r).Value, _ Application.Index(WS.Range("C2:C" & lr2), _ Application.Match(f.Cells(r, 2).Value, WS.Range("A2:A" & lr2), 0))) Next r MsgBox "Process Completed", vbInformation, "Done" End Sub

العفو أخي @Moh2024 يسعدنا أننا إستطعنا مساعدتك تمت إظافة شرح الكود في المشاركة السابقة بالتوفيق.

وعليكم السلام ورحمة الله تعالى وبركاته ادن انفترض اننا لدينا ورقتين الاولى باسم الرئيسية والثانية باسم استثناءات القائمة الرئيسية للارقام على ورقة الرئيسية بداية من الخلية A3 الى غاية A10000 (يمكنك تعديلها بما يناسبك) قائمة الارقام المرغوب إزالتها موجودة في ورقة إستثناءات بداية من الخلية A2 الى غاية A10000 (يمكنك تعديلها بما يناسبك) مكان استخراج الأرقام بعد إزالة العدم مرغوب بها هو العمود B في حالة استخدامك لإصدارات قديمة من برنامج الأوفيس يمكنك استخدام الصيغة التالية ورقة الرئيسية الخلية B3 =IF(ISNUMBER(MATCH(A3,'استثناءات '!$A$2:$A$10000,0)), "", A3) يمكنك استخراجها بدون فراغات بعد دالك في اي عمود من اختيارك بالصيغة التالية =IFERROR(INDEX($B$3:$B$10000,MATCH(0,COUNTIF(D2:$D$2,$B$3:$B$10000)+(COUNTIF($B$3:$B$10000,$B$3:$B$10000)<>1),0)),"") اما في حالة استخدامك للنسخ الحديثة وهدا أفضل دائما يمكنك استخدام احدى المعادلات التالية =FILTER(الرئيسية!A3:A10000, (ISERROR(MATCH(الرئيسية!A3:A10000, 'استثناءات '!A2:A10000, 0))) * (LEN(الرئيسية!A3:A10000) > 0)) او =FILTER(الرئيسية!A3:A10000, (ISERROR(MATCH(الرئيسية!A3:A10000, 'استثناءات '!A2:A10000, 0))) * (الرئيسية!A3:A10000 <> 0)) كما في المثال المرفق phone_numbers.xlsx في حالة الرغبة باستخدام الاكواد يمكنك استخدام هدا Sub Extract_the_main() Dim i&, b&, n&, xMatch As Boolean Dim OneRng1 As Variant, OneRng2 As Variant Dim Cnt() As Variant, tmp As Object Dim dest As Worksheet: Set dest = Sheets("الرئيسية") Dim WS As Worksheet: Set WS = Sheets("استثناءات") OneRng1 = dest.Range("A2:A" & dest.Cells(dest.Rows.Count, "A").End(xlUp).Row).Value OneRng2 = WS.Range("A2:A" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(OneRng2, 1) If Not IsEmpty(OneRng2(i, 1)) And Not tmp.exists(OneRng2(i, 1)) Then tmp.Add OneRng2(i, 1), True End If Next i xMatch = False ReDim Cnt(1 To UBound(OneRng1, 1), 1 To 1) b = 1 n = 0 For i = 1 To UBound(OneRng1, 1) If Not IsEmpty(OneRng1(i, 1)) Then If tmp.exists(OneRng1(i, 1)) Then xMatch = True ElseIf OneRng1(i, 1) <> 0 Then Cnt(b, 1) = OneRng1(i, 1) b = b + 1 n = n + 1 End If End If Next i If Not xMatch Or n = 0 Then MsgBox "لم يتم العثور على أي تطابق بين البيانات", vbExclamation, "نتائج التصفية" Exit Sub End If dest.Range("C2:C" & dest.Rows.Count).ClearContents If b > 1 Then dest.Range("C2").Resize(b - 1, 1).Value = Cnt End If MsgBox "تم تصفية البيانات بنجاح" & vbCrLf & "عدد الأرقام المصفاة: " & n, vbInformation, "ورقة " & dest.Name End Sub مع امكانية النسخ لنفس الورقة ( الرئيسية ) او ورقة مغايرة في المرفق التالي phone_numbers vba.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub UpdateDates() ' تعريف المتغيرات Dim WS As Worksheet, f As Worksheet Dim a As Variant, b As Variant Dim lr As Long, Irow As Long Dim i As Long, j As Long Set WS = ThisWorkbook.Sheets("CALL") Set f = ThisWorkbook.Sheets("DATA") '*** (lr) Sheets("CALL")<<====("a") تحديد آخر صف غير فارغ في العمود lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row '*** (Irow) Sheets("DATA")<<====("B") تحديد آخر صف غير فارغ في العمود Irow = f.Cells(f.Rows.Count, "B").End(xlUp).Row '***تخزين البيانات في المتغيرات*** '(A2)البيانات من النطاق Sheets("DATA")<<==== (a)تُخزن في المتغير a = WS.Range("A2:E" & lr).Value '(A2)البيانات من النطاق Sheets("CALL")<<==== (b)تُخزن في المتغير b = f.Range("A2:E" & Irow).Value '******التكرار عبر الصفوف****** ' يتم استخدام حلقتين تكراريتين For لتصفح البيانات في كل من المصفوفتين a و b 'b Sheets("DATA")<<===='الأولى تكرر عبر الصفوف في البيانات المخزنة For i = 1 To UBound(b, 1) 'a Sheets("CALL")<<===='الثانية تكرر عبر الصفوف في البيانات المخزنة For j = 1 To UBound(a, 1) '*****التحقق من المطابقة **** 'داخل الحلقة الثانية يتم التحقق من شرطين '1======= Sheets("CALL")====>> (b) إذا كانت القيمة في العمود الثاني من ' Sheets("DATA")====>> (a) تساوي القيمة في العمود الأول من '2======= Sheets("DATA")====>> (a) وإذا كانت القيمة في العمود الثالث من ' Sheets("CALL")====>> (b) تساوي القيمة في العمود الثاني من If b(i, 2) = a(j, 1) And b(i, 3) = a(j, 2) Then 'Sheets("DATA") إذا تحقق الشرطان، يتم تحديث الخلية في العمود الخامس من 'Sheets("CALL") بالقيمة المقابلة في العمود الثالث من f.Cells(i + 1, 5).Value = a(j, 3) '(Exit For)الخروج من الحلقة 'يتم استخدامه للخروج من الحلقة الداخلية عند العثور 'على تطابق مما يوفر الوقت ويجعل الكود أكثر كفاءة Exit For End If Next j Next i End Sub نموذج V1.xlsm

لقد فكرت في هدا لاكن ماجاء في اخر مشاركة لك كان العكس العفو اخي يسعدنا اننا استطعنا مساعدتك

بارك الله فيك استاد @أ / محمد صالح بالفعل هي دالة جميلة ومختصرة لاكن ربما المشكلة على ما أعتقد أن السائل يريد حدف العلامات الزائدة مع بقاء البيانات في نفس العمود B لهدا اعتمادا على الدالة التي زودتنا بها يمكننا بناء كود مشابه ومختصر ينفد المطلوب على نفس العمود Sub Remove_additional_Tags() Dim WS As Worksheet, i As Long, _ OneRng As Range, cell As Range, _ tmp As String, rCount As Long Set WS = ThisWorkbook.Sheets("ورقة2") Set OneRng = WS.Range("B7:B" & WS.Cells(WS.Rows.Count, "B").End(xlUp).Row) For Each cell In OneRng If Not IsEmpty(cell.Value) Then tmp = Trim(cell.Value) Do While Right(tmp, 1) = "+" tmp = Trim(Left(tmp, Len(tmp) - 1)) Loop cell.Value = tmp End If Next cell End Sub RS_ST_196 V4.xls

وعليكم السلام ورحمة الله تعالى وبركاته ضع الكود التالي في Module Sub HideRowsWith_Zero() Dim Sh As Worksheet Dim i As Long, lastRow As Long Set Sh = ThisWorkbook.Sheets("تفاصيل") lastRow = Sh.Columns("A:C").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 4 To lastRow If Sh.Cells(i, 2).Value = 0 And Sh.Cells(i, 3).Value = 0 Then Sh.Rows(i).Hidden = True Else Sh.Rows(i).Hidden = False End If Next i End Sub وفي حدث ورقة تفاصيل Private Sub Worksheet_Activate() HideRowsWith_Zero End Sub اخفاء الصفوف.xlsb

حاول اخي الكريم مراجعة الموضوع التالي ربما يفيدك

اخي ليس هناك خطا عبارة دخول ناجح مؤقتة لحين مغادرة المستخدم للملف بحيث الكود الموجود في حدث ThisWorkbook هو المسؤول على حساب التوقيت الفعلي يتم استبدالها تلقائيا عن تسجيل الخروج كما في الصورة ادناه قم بتغيير ' التحقق إذا كان هناك سجل سابق لتوقيت الدخول If lrow > 1 Then الى ' التحقق إذا كان هناك سجل سابق لتوقيت الدخول If lrow > 2 Then

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي الصيغة التالية '=IFERROR(INDEX(Feuil1!B$2:B$200, AGGREGATE(15, 6, ROW(Feuil1!$B$2:$B$200) / ($F$3=Feuil1!$A$2:$A$200), ROW(Feuil2!D1))-1), "") او =IFERROR(INDEX(Feuil1!B$2:B$200,SMALL(IF($F$3=Feuil1!$A$2:$A$200,ROW(Feuil1!$B$2:$B$200)-1),ROW(Feuil2!D1))),"") recherche 1.xlsx

اخي الفاضل مربع inputbox في Excel لا يدعم إخفاء كلمة السر أو إظهارها كنجوم أو علامات. هو ببساطة يعرض مربع حوار لإدخال النص دون تقديم خيارات لتنسيق العرض مثل إخفاء النص. لإخفاء كلمة السر أو إظهارها كنجوم، يجب عليك استخدام Userform الذي يتيح لك تخصيص واجهة المستخدم بشكل أكبر. يمكنك استخدام خاصية PasswordChar لمربع النص (Textbox) لعرض كلمات المرور كنجوم أو أي رمز آخر تختاره بعد معاينة الكود الخاص بك حاولت تجربة انشاء شاشة دخول بسيطة بنفس الفكرة مع اظافة بعض التحسينات على الكود وطريقة اشتغالك على الملف مع اظافة ورقة خاصة بتسجيل الزوار باسم AccessLog لتتبع المستخدمين والمدة المستغرقة في استخدام الملف هدا مجرد اقتراح بسيط للفائدة فقط اليك الكود مع الشرح لتتمكن من تعديله بما يناسبك Private Sub UserForm_Initialize() Set f = Sheets("list") Set MonDico = CreateObject("Scripting.Dictionary") ' قراءة القيم من العمود L، بدءًا من الخلية L2 حتى آخر خلية بها بيانات a = f.Range("l2:l" & f.[L65000].End(xlUp).Row).Value For i = LBound(a) To UBound(a) ' إضافة القيم غير الفارغة إلى Dictionary (القيم الفريدة فقط) If a(i, 1) <> "" Then MonDico(a(i, 1)) = "" Next i Me.ComboBox1.List = MonDico.keys End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet, logWs As Worksheet Dim lrow As Long, clé As String Dim password As String, Xtime As String Static AttemptCount As Integer, username As String ' تعيين ورقة العمل "list" Set ws = ThisWorkbook.Sheets("list") ' تعيين ورقة العمل للتسجيل Set logWs = ThisWorkbook.Sheets("AccessLog") ' الحصول على اسم المستخدم من ComboBox username = ComboBox1.Value ' التحقق إذا كان اسم المستخدم مدخل If username = "" Then MsgBox "يرجى اختيار اسم المستخدم.", vbExclamation Exit Sub End If ' العثور على آخر صف يحتوي على بيانات في العمود 12 (L) lrow = ws.Cells(ws.Rows.Count, 12).End(xlUp).Row ' البحث عن كلمة السر المرتبطة بالاسم For i = 2 To lrow If ws.Cells(i, 12).Value = username Then password = ws.Cells(i, 13).Value Exit For End If Next i ' الحصول على كلمة السر المدخلة من مربع النص clé = TextBox1.Text ' التحقق إذا كانت كلمة السر المدخلة صحيحة If clé = password Then ' تسجيل الدخول الناجح With logWs ' العثور على آخر صف فارغ في الأعمدة A, B, C و D lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Cells(lrow, 1).Value = username .Cells(lrow, 2).Value = Date .Cells(lrow, 3).Value = Format(Time, "hh:mm:ss") ' توقيت الدخول فقط كوقت .Cells(lrow, 4).Value = "دخول ناجح" ' إضافة رسالة تسجيل الدخول الناجح End With ' عرض رسالة ترحيب MsgBox "مرحبا " & username & "، لقد تم تسجيل الدخول بنجاح!", vbInformation ' إظهار Excel Application.Visible = True ' إغلاق UserForm Unload Me ' إعادة تعيين عدد المحاولات AttemptCount = 0 Else ' معالجة الدخول الفاشل AttemptCount = AttemptCount + 1 If AttemptCount >= 3 Then MsgBox "لقد تجاوزت عدد المحاولات المسموح بها. سيتم حفظ وإغلاق الملف.", vbExclamation ThisWorkbook.Save Application.Quit Else MsgBox "الرجاء التأكد من كلمة السر! المحاولة " & AttemptCount & " من 3" Me.TextBox1.Text = "" End If End If End Sub Private Sub CommandButtonClose_Click() Dim answer As VbMsgBoxResult answer = MsgBox("هل أنت متأكد من الخروج من البرنامج؟", vbYesNo + vbQuestion, "تأكيد الإغلاق") If answer = vbYes Then ' حفظ المصنف ThisWorkbook.Save ' إغلاق المصنف ThisWorkbook.Close SaveChanges:=False Application.Quit End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True MsgBox "يرجى استخدام زر الإغلاق المخصص لإغلاق النموذج", vbInformation End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub '**************************************** Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim logWs As Worksheet Dim lrow As Long Dim currentTime As Date Dim entryTime As Date On Error Resume Next Set logWs = ThisWorkbook.Sheets("AccessLog") If logWs Is Nothing Then MsgBox "ورقة العمل 'AccessLog' غير موجودة.", vbExclamation Exit Sub End If ' الحصول على الوقت الحالي currentTime = Now ' العثور على آخر صف يحتوي على بيانات lrow = logWs.Cells(logWs.Rows.Count, 1).End(xlUp).Row ' التحقق إذا كان هناك سجل سابق لتوقيت الدخول If lrow > 1 Then ' الحصول على توقيت الدخول entryTime = logWs.Cells(lrow, 3).Value ' تسجيل توقيت الخروج With logWs .Cells(lrow, 4).Value = Format(currentTime, "hh:mm:ss") ' توقيت الخروج فقط كوقت End With End If On Error GoTo 0 ' إلغاء التعامل مع الأخطاء ' حفظ المصنف ThisWorkbook.Save ' إغلاق المصنف ThisWorkbook.Close SaveChanges:=False ' تأكد من إغلاق المصنف بشكل صحيح ' إذا كنت تريد إغلاق Excel بالكامل، استخدم: 'Application.Quit End Sub عند الانتهاء من تعديل برنامجك حاول وضع باسوورد لمحرر الاكواد تفاديا للتلاعب بها كلمات المرور واسماء المستخدمين الحالية كما في الصورة فوق بالتوفيق.... شاشة دخول.xlsb

هل انت متأكد من تنسيق اللغة على جهازك ؟

لا اعلم مادا تقصد هل كيفية ادراج الكود او كيفية تطبيقه على ملفات اخرى الاولى لايمكنني شرحها يمكنك البحث عنها ستجدها صوة وصورة اما الاحتمال الثاني وهو الارجح على ما اعتقد لكي تطبق الكود على ملفات اخرى لابد ان تفهمه اولا لتتمكن من تعديله بما يناسبك سأقوم بمحاولة اظافة بعض التعليقات المهمة للتوضيح Sub Collection_of_books_Sheet1() '****"RS_ST_196"' هذا الماكرو يقوم بتجميع أسماء الطلاب والكتب من ورقة ' ويقوم بنسخها إلى ورقة1 مع حساب عدد الكتب لكل طالب Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long Dim studentName As String, bookName As String, n As String Dim bookNumber As Variant, row As Range, lr As Long Dim startRow As Long, ling As Long, bCount As Integer Dim rngCell As Range Application.ScreenUpdating = False '***** تحديد أوراق العمل Set WS = ThisWorkbook.Sheets("RS_ST_196") Set dest = ThisWorkbook.Sheets("Sheet1") '******** "RS_ST_196" ,ورقة ' تحديد آخر صف في العمود AK lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row With dest.Range("A2:C" & dest.Cells(dest.Rows.Count, "A").End(xlUp).row) .ClearContents ' مسح جميع البيانات في النطاق .ClearFormats ' مسح جميع التنسيقات في النطاق End With ling = 2 ' بدء الكتابة من الصف 2 في ورقة "Sheet1" ' حلقة لتمرير جميع الصفوف في ورقة المصدر من الصف 18 إلى آخر صف مستخدم For i = 18 To lastRow ' التحقق مما إذا كان الصف مخفيًا (إذا لم يكن مخفيًا، يتم معالجة الصف) If Not WS.Rows(i).Hidden Then ' الحصول على اسم الطالب من العمود "AK" studentName = WS.Cells(i, "AK").Value ' التحقق مما إذا كان اسم الطالب يبدأ بـ "اسم الطالب: " If InStr(studentName, "اسم الطالب: ") = 1 Then ' إزالة "اسم الطالب: " من بداية النص للحصول على الاسم الفعلي للطالب studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" ' لتجميع أسماء الكتب bCount = 0 ' عداد للكتب startRow = i + 2 ' البدء من الصف الذي يليه للتحقق من الكتب ' حلقة لتمرير جميع الكتب المرتبطة بالطالب Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value '(عمود التسلسل م) التأكد من أن الكتاب ليس مجرد عنوان عمود وأن رقم الكتاب غير فارغ If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And Not IsEmpty(bookNumber) Then ' تجميع أسماء الكتب في متغير n If n = "" Then n = bookName Else n = n & " + " & bookName End If bCount = bCount + 1 ' زيادة عدد الكتب لكل طالب End If startRow = startRow + 1 ' الانتقال إلى الصف التالي Loop '** نسخ النتائج ' كتابة اسم الطالب، أسماء الكتب المجتمعة، وعدد الكتب في ورقة الوجهة dest.Cells(ling, "A").Value = studentName ' اسم الطالب dest.Cells(ling, "B").Value = n ' أسماء الكتب dest.Cells(ling, "C").Value = bCount ' عدد الكتب ling = ling + 1 ' الانتقال إلى الصف التالي لكتابة بيانات الطالب التالي End If End If Next i '** تحديد آخر صف مستخدم في الاعمدة A:C "Sheet1" lr = dest.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set rngCell = dest.Range("A2:C" & lr) '** تنسيق الخلايا في النطاق المحدد With rngCell .Font.Bold = True ' تنسيق الخط .MergeCells = False ' التأكد من عدم دمج الخلايا .HorizontalAlignment = xlCenter ' ضبط المحاذاة الأفقية إلى الوسط .VerticalAlignment = xlCenter ' ضبط المحاذاة الرأسية إلى الوسط .WrapText = True ' تفعيل التفاف النص ' ضبط ارتفاع الصفوف إلى 35 For Each row In .Rows row.RowHeight = 35 Next row End With '** إضافة حدود للخلايا في النطاق For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub

تفضل اخي جرب هدا الاقتراح حاول اولا ترتيب عناصر التيكست بوكس على اليوزرفورم بشكل متتابع وفي وحدة class module ضع الكود التالي مع تسميته مثلا ب Officena كما في الصورة ادناه Public WithEvents MultTextbox As MSForms.TextBox Private Sub MultTextbox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If TypeOf MultTextbox Is MSForms.TextBox Then Select Case KeyCode Case 37 ' السهم اليسار SendKeys "+{TAB}" Case 39 ' السهم اليمين SendKeys "{TAB}" Case Else ' السماح لجميع المفاتيح الأخرى بالعمل بشكل طبيعي Exit Sub End Select End If End Sub Private Sub MultTextbox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim ctrl As MSForms.Control Dim isTextBox As Boolean isTextBox = TypeOf MultTextbox Is MSForms.TextBox If isTextBox Then With USERFORM1 '<<======== 'قم بتعديل الاسم الى اسم النمودج الخاص بك For Each ctrl In .Controls ' التحقق من أن العنصر هو TextBox If TypeOf ctrl Is MSForms.TextBox Then ctrl.BackColor = RGB(255, 255, 255) 'ابيض كافتراضي' لون الخلفية End If Next MultTextbox.BackColor = RGB(255, 255, 128) ' تغيير لون الخلفية للأصفر عند التركيز End With End If End Sub وفي داخل اليوزرفورم ضع الكود التالي Dim i As Integer Dim ctrl As Control Dim TxtBx() As New Officena Private Sub UserForm_Initialize() Dim i As Long, ctrl As MSForms.Control i = 1 For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ReDim Preserve TxtBx(i) Set TxtBx(i).MultTextbox = ctrl i = i + 1 End If Next End Sub تفضل اليك المرفقات للتجربة User_Move left and right.rar

إذن أعد قراءة ما تم نشره في آخر مشاركة لتفهم للأسف، في VBA و MSForms.DataObject، لا يمكنك تنفيذ اللصق مباشرة في واجهة التطبيقات الخارجية مثل محرك جوجل أو أي تطبيق آخر من خلال كود VBA إذا كنت تحتاج إلى مميزات تتطلب تفاعلًا مع واجهات أكثر تعقيدًا، فقد تحتاج إلى استخدام أدوات خارجية أو لغات برمجة أخرى توفر إمكانيات أكثر تقدمًا مثل AutoIt أو AutoHotkey.

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

يسعدنا أخي @mahmoud nasr alhasany أننا استطعنا مساعدتك. هذا مجرد اجتهاد مني لأنني بصراحة ليست لي فكرة مسبقة أو خبرة في مجال المحاسبة. لأنه بعيد كل البعد عن مجال عملي. بالتوفيق

جرب هدا التعديل Private Sub CommandButton2_Click() ' التحقق من وجود ورقة العمل "Transferts" If Not WorksheetExists("Log") Then MsgBox "غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If ' التحقق من القيم الفارغة If ListBox1.ListIndex = -1 Or (ComboBox3.Value = "" And Me.TextBox1.Value = "") Then Exit Sub If ListBox1.ListIndex <> -1 Then ' التحقق من صحة البيانات If Not IsNumeric(TextBox1.Value) Then MsgBox "الكمية يجب أن تكون رقمًا." Exit Sub End If If ComboBox1.ListIndex = -1 Then MsgBox "يرجى اختيار المخزن الذي سيتم النقل منه." Exit Sub End If Dim wsSales As Worksheet, wsStock As Worksheet Dim lastRowSales As Long, lastRowStock As Long Dim i As Long, j As Long Dim invoiceNo As Long, fromStore As String, toStore As String Dim fromStore1 As Long, toStore2 As Long Dim itemCode As String, quantity As Long, newQuantity As Long Dim quantityDiff As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value fromStore1 = Val(stocktr.Value) toStore2 = Val(stocktrr.Value) Set wsSales = Worksheets("Log") Set wsStock = Worksheets("Inventaire") lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then quantity = wsSales.Cells(i, "J").Value ' الكمية الأصلية newQuantity = Val(TextBox1.Value) ' الكمية المعدلة quantityDiff = newQuantity - quantity ' الفرق بين الكمية الأصلية والمعدلة ' تعديل الكمية في سجل المبيعات wsSales.Cells(i, "J").Value = newQuantity wsSales.Cells(i, "M").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "N").Value = Environ("Username") ' اسم المستخدم ' تحديث المخزون بناءً على الفرق في الكمية lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "B").Value = fromStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value + quantityDiff ' إضافة أو طرح الفرق من المخزن الأصلي ElseIf wsStock.Cells(j, "B").Value = toStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value - quantityDiff ' خصم الفرق من المخزن الآخر wsStock.Cells(j, "M").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "N").Value = Environ("Username") ' اسم المستخدم End If Next j End If Next i MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" Else MsgBox "المرجوا تحديد الصف المراد تعديله", vbCritical, "" End If End Sub

العفو اخي يسعدنا اننا استطعنا مساعدتك

تفضل اخي Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim F As Worksheet Dim WS As Worksheet Dim rowNumber As Long Dim cellValue As String '********التحقق من أن النقر كان على الخلية K2 فقط If Not Intersect(Target, Me.Range("K2")) Is Nothing Then Cancel = True Set F = ThisWorkbook.Sheets("إدخال") Set WS = ThisWorkbook.Sheets("نموذج") ' الحصول على قيمة الخلية K2 cellValue = F.Range("K2").Value '*********التحقق مما إذا كانت كلمة "تقديم" موجودة في الخلية K2*** If InStr(cellValue, "تقديم") > 0 Then ' تحديد الصف الأول rowNumber = 2 '******* نسخ البيانات من الصف الأول إلى ورقة "نموذج************ WS.Range("B2").Value = F.Cells(rowNumber, "B").Value WS.Range("H2").Value = F.Cells(rowNumber, "C").Value WS.Range("B7").Value = F.Cells(rowNumber, "D").Value WS.Range("B3").Value = F.Cells(rowNumber, "E").Value WS.Range("G3").Value = F.Cells(rowNumber, "F").Value WS.Range("B4").Value = F.Cells(rowNumber, "I").Value WS.Range("B8").Value = F.Cells(rowNumber, "J").Value WS.Range("E7").Value = F.Cells(rowNumber, "G").Value WS.Range("H7").Value = F.Cells(rowNumber, "H").Value Else MsgBox "كلمة 'تقديم' غير موجودة في الخلية K2.", vbExclamation End If End If End Sub طلب اجازة v1.xlsb

والله اتعبتني ام أنك لغاية اللحظة لم تستوعب كلامي لحظات سوف اقوم بكتابة الكود لينسخ اول صف على الرئيسية إلى الخلايا المطلوبة عند الظغط على خلية K التي تتضمن كلمة تقديم اان الكود لايمكنه تسغيله من خلال كلمة الا بشروط انت لم تستوعبها ولك واسع النظر

الموضوع ليس مسألة تعلم أخي الكريم من متطلبات كتابة الكود معرفة ما هي النتيجة المتوقعة مسبقا لاخذها في عين الاعتبار داخل الكود !!!! هل مثلا عند وجود كلمة تقديم ينفذ وعند عدم وجودها لا يتم تنفيذ الكود او عدم وجود الإسم هناك عديد من الاحتمالات وهذا اول درس لك 😄😄😄 يجب ذكر النتيجة النهائية وان شاء الله سأحاول شرح الكود للاستفادة

تمام لاكن الملف يتضمن كلمة تقديم واحدة هل ورقة الرئيسية تتضمن صف واحد! ام انك ستقوم بكتابتها عند تعبئة الصفوف الموالية

لم افهم جيدا هل تقصد انك سوف تختار الاسم في ورقة نموذج والظغط على زر يقوم بنسخ البيانات او تقصد عند الظغط في الخلية المجاورة للاسم المطلوب يتم نسخ البيانات المجاورة له وضح اكثر