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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SansDoublons() Dim dict As Object, tmp As Variant Dim cell As Range, i As Long Dim f As Worksheet: Set f = Sheets("Sheet1") Dim WS As Worksheet: Set WS = Sheets("Sheet2") Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In f.Range("b5:b100") If Len(cell.Value) > 0 And Not dict.exists(cell.Value) Then dict.Add cell.Value, Nothing End If Next cell If dict.Count > 0 Then WS.Range("b5:b100").ClearContents tmp = dict.Keys For i = LBound(tmp) To UBound(tmp) WS.Cells(i + 5, 2).Value = tmp(i) Next i End If Application.ScreenUpdating = True End Sub لتشغيل الماكرو تلقائيا عند الغيير في عمود (b) ورقة 1 في حدث Sheet1 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("b5:b100")) Is Nothing Then SansDoublons End If End Sub نقل القيم بدون تكرار.xlsb

بارك الله فيك اخي العزيز kanory وفي سعيك لإسعاد الغير، صحيح هناك سعادة ولذة لا يعرفها إلا من تصدق بها أو ساهم بإدخال السرور على محتاج. ادعوا الله أن تكون دائمًا سباقا لعمل الخير.

تفضل البيانات المكرره.mdb

يا ريت تتفضل علينا بشرح الكود الحالي حتى نتمكن من فهمه ومساعدتك في تعديله

عمل ممتاز وجعلها الله في ميزان حساناتك وجزاك كل خير

لا حول ولا قوة الا بالله ارفق محاولتك اعدل عليها .. بكذا تتعلم وتعرف اين الخلل

ليس استعلاما واحدا بل استعلامات فانت تتعامل مع جدولين مرتبطين .. وتريد تكرار البيانات في الجدولين مع مراعاة اختلاف رقم القيد المرتبط المسألة بحاجة الى وسيط ( ذاكرة مؤقتة ) تحفظ السجل القديم لاستخدامه كمعيار ووسيط آخر يمثل السجلات الجديدة تمت المعالجة على النحو الذي ذكرته اعلاه Dailyrepetition2.rar

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

بارك الله لك أستاذ محمد وهذا جهدي المتواضع في كود يحذف الموجود في قائمة الاستثناءات ويبقي غير الموجود وفي نفس العمود Sub FilterUniqueItems() Dim rngA As Range, rngB As Range, cell As Range Dim dict As Object, outputRow As Long Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("الرئيسية") Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("استثناءات") Set rngA = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row) Set rngB = ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") For Each cell In rngB dict(cell.Value) = 1 Next cell outputRow = 1 For Each cell In rngA If Not dict.exists(cell.Value) Then ws.Cells(outputRow, "A").Value = cell.Value outputRow = outputRow + 1 End If Next cell ws.Range("A" & outputRow & ":A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents MsgBox "Done by mr-mas.com",,"M.A.S" End Sub بالتوفيق للجميع

إجابتي بدون رؤية الملفات؛ لأني على الهاتف حاليا. المعادلة هي مجرد معادلة بحث عن الرقم الموجود في الخلية m12 وجلب القيم من العمود الثالث في النطاق المسمى prod للوصول إلى النطاقات المسماة من تبويب معادلات formulas ثم إدارة الأسماء name manager بالتوفيق

بارك الله فيكم جميعا ولإثراء الموضوع وتحقيقا لهوايتي المفضلة اختصار الأكواد يمكنك أخي صاحب الاستفسار أن تضع هذا الكود مكان الإجراء القديم Sub REs_Data() lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("CAll").Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr myval = Evaluate("=IFERROR(INDEX(CAll!$C$2:$C$" & lr2 & ",MATCH(B" & r & ",CAll!$A$2:$A$" & lr2 & ",0)),"""")") Range("E" & r).value = IIf(myval = "", Range("E" & r).value, myval) Next r MsgBox "Done by mr-mas.com", , "M.A.S" End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا 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

بسم الله ما شاء الله ... عمل جميل جدا

هذا ما كنت أحاول فهمه كما سبق الذكر يمكنك ذالك بدون الاعتماد أو إظافة الارتباط التشعبي ضع الكود التالي في حدث ورقة الرئيسية Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim f As Worksheet: Set f = ThisWorkbook.Sheets("الرئيسية") Application.ScreenUpdating = False f.Range("M2:M" & f.Rows.Count).ClearContents ' تحديث العمود "M" بالنص "تفاصيل الطلب" لكل صف يحتوي على قيمة في العمود "B" For i = 2 To f.Cells(f.Rows.Count, "B").End(xlUp).Row If f.Cells(i, "B").Value <> "" Then f.Cells(i, "M").Value = "تفاصيل الطلب" ' <<=====' يمكنك تعديل النص بما يناسبك End If Next i Application.ScreenUpdating = True If Not Intersect(Target, Me.Columns("M")) Is Nothing Then Dim lr As Long, OneRng As Range Dim rCrit As String, tmp As Boolean tmp = False On Error Resume Next tmp = Not ThisWorkbook.Sheets("التفصيلية") Is Nothing On Error GoTo 0 If Not tmp Then MsgBox "ورقة العمل التفصيلية غير موجودة", vbExclamation Exit Sub End If If Target.Row > 1 Then If Me.Cells(Target.Row, "M").Value <> "" And Me.Cells(Target.Row, "B").Value <> "" Then Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("التفصيلية") If WS.AutoFilterMode Then WS.AutoFilterMode = False rCrit = Me.Cells(Target.Row, "B").Value If rCrit <> "" Then lr = WS.Cells(WS.Rows.Count, "J").End(xlUp).Row Set OneRng = WS.Range("J2:J" & lr).Find(What:=rCrit, LookIn:=xlValues, LookAt:=xlWhole) If Not OneRng Is Nothing Then WS.Activate With WS.Range("B2:O" & lr) .AutoFilter 9, rCrit End With Else MsgBox "غير موجود في قاعدة البيانات" & " : " & rCrit, 16 End If End If End If End If End If End Sub طلب فلتر V3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام شيئ كهدا Private Sub CommandButton19_Click() 'TEXTBOX1'نسخ الى الحافظة Dim objCpt As New MSForms.DataObject Dim textToCopy As String If TextBox1.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", 64 Else ' الحصول على النص من TextBox1 textToCopy = TextBox1.Text ' وضع النص في الحافظة objCpt.SetText textToCopy objCpt.PutInClipboard ' MsgBox "تم نسخ النص إلى الحافظة.", vbInformation End If End Sub '************************** Private Sub CommandButton20_Click() Dim objCpt As New MSForms.DataObject Dim textToCopy As String ' الحصول على نص الحافظة On Error Resume Next objCpt.GetFromClipboard textToCopy = objCpt.GetText On Error GoTo 0 ' التحقق مما إذا كانت TextBox1 فارغة If Me.TextBox1.Text = "" Then MsgBox "TextBox1 فارغ. لا يمكن إجراء العملية.", vbExclamation ' التحقق مما إذا كانت الحافظة فارغة ElseIf textToCopy = "" Then MsgBox "الحافظة فارغة. يرجى نسخ نص إلى الحافظة أولاً.", vbExclamation Else ' لصق نص الحافظة إلى TextBox6 Me.TextBox6.Text = textToCopy ' MsgBox "تم لصق النص من الحافظة إلى TextBox6.", vbInformation End If End Sub ولنسخ البيانات من خارج اليوزرفورم او العكس Private Sub CommandButton2_Click() 'TEXTBOX 1 ' لصق في الخلية النشطة If Me.TextBox1.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", 64 Exit Sub End If ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' لصق النص من TextBox1 في الخلية النشطة activeCell.Value = Me.TextBox1.Value MsgBox "تم لصق النص في الخلية النشطة.", vbInformation End Sub '***************** Private Sub CommandButton3_Click() 'TEXTBOX 6 ' لصق في الخلية النشطة If Me.TextBox6.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", 64 Exit Sub End If ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' لصق النص من TextBox6 في الخلية النشطة activeCell.Value = Me.TextBox6.Value MsgBox "تم لصق النص في الخلية النشطة.", vbInformation End Sub '**************** Private Sub CommandButton21_Click() 'TEXTBOX 1'نسخ ولصق من الخلية النشطة ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' التحقق من كون الخلية النشطة فارغة If IsEmpty(activeCell.Value) Then MsgBox "الخلية النشطة فارغة. يرجى تحديد خلية تحتوي على بيانات.", 64 Exit Sub End If ' نقل النص من الخلية النشطة إلى TextBox6 Me.TextBox1.Value = activeCell.Value MsgBox "TextBox1" & " " & "تم نقل قيمة الخلية النشطة إلى", vbInformation End Sub '************* Private Sub CommandButton5_Click() 'TEXTBOX 6'لصق في الخلية النشطة ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' التحقق من كون الخلية النشطة فارغة If IsEmpty(activeCell.Value) Then MsgBox "الخلية النشطة فارغة. يرجى تحديد خلية تحتوي على بيانات.", 64 Exit Sub End If ' نقل النص من الخلية النشطة إلى TextBox6 Me.TextBox6.Value = activeCell.Value MsgBox "TextBox6" & " " & "تم نقل قيمة الخلية النشطة إلى", vbInformation End Sub بما ان ملفك يتضمن عدة اخطاء يجب اصلاحها حاولت فقط وضع الاكواد على Private Sub CommandButton19_Click و Private Sub CommandButton20_Click اليك ملفك مع ملف تم انشاءه لتطبيق عليه بعض الأمثلة يمكنك اختيار ما يناسبك مثال للتجربة.rar

بارك الله لك أخي الكريم يعني الاستاذ الشهابي قام لك بالكود السابق (ولم تكلف نفسك فهم كل سطر فيه حتى يمكنك تعديله فيما بعد) وتريد الآن أن يقوم لك أحدهم بالكود الجديد؟؟؟؟؟؟ ربما حضرتك لم تصل إليك حقيقة أن المنتدى تعليمي لمن يتعلم ويواجه بعض المشكلات أما إن كان أحدنا يريد خدمة مدفوعة من غيره بحيث لا يتعب نفسه فمجالها التعاملات الخاصة وليس موضوعات المنتدى والله الموفق