خالد القدس2

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

السلام عليكم ورحمة الله بارك الله فيك أستاذ أبوعيد أحسنت بهذا التنبيه asa.rar

الاساتذة الكرام السلام عليكم ورحة الله وبركاته تقبل الله منا ومنكم صالح الاعمال وكل عام وانتم بخير وعافية ونعم ظاهرة وباطنة ارجو المساعدة في تعديل هذا الكود المميز بنكهة الذكاء الاصطناعي ليقوم بتبادل البيانات بين 4 ملفات .... رابط الملفات حيث حجمها كبير https://www.mediafire.com/file/6nqdhfbiqddkd3o/asa.rar/file Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim wb As Workbook Dim rngSource As Range, rngTarget As Range Dim arrFiles As Variant Dim conn As Object, rs As Object Dim filePath As String Dim i As Long, lastRow As Long If IsSyncing Then Exit Sub If Sh.CodeName <> "Sheet1" Then Exit Sub If Intersect(Target, Sh.Range("A1:CV1")) Is Nothing Then Exit Sub IsSyncing = True ' تحديد الصف الأخير الفارغ في العمود B داخل الملف الرئيسي lastRow = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row Set rngSource = Sh.Range("A1:CV" & lastRow) ' تحديد المسارات ديناميكيًا اعتمادًا على موقع ملف Excel الحالي arrFiles = Array(ThisWorkbook.Path & "\asa1.xlsm", _ ThisWorkbook.Path & "\asa2.xlsm", _ ThisWorkbook.Path & "\asa3.xlsm", _ ThisWorkbook.Path & "\asa4.xlsm") For i = 0 To UBound(arrFiles) On Error Resume Next Set wb = Application.Workbooks(arrFiles(i)) On Error GoTo 0 If Not wb Is Nothing Then ' إذا كان الملف مفتوحًا، يتم التعديل مباشرة في الجدول lastRow = wb.Sheets("data").Cells(wb.Sheets("data").Rows.Count, 2).End(xlUp).Row Set rngTarget = wb.Sheets("data").Range("A1:CV" & lastRow) rngTarget.Value = rngSource.Value Else ' إنشاء الاتصال بـ ADO Set conn = CreateObject("ADODB.Connection") filePath = arrFiles(i) conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filePath & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMEX=1"";" ' التحقق من أن الاتصال مفتوح قبل تنفيذ أي استعلام If conn.State = 1 Then ' استدعاء أسماء الجداول المتاحة للتحقق من وجود Table1 Set rs = conn.OpenSchema(20) ' 20 = adSchemaTables Do While Not rs.EOF Debug.Print rs.Fields("TABLE_NAME").Value rs.MoveNext Loop rs.Close ' تنفيذ التحديث فقط إذا كان الجدول موجودًا conn.Execute "UPDATE [data$] SET F1='" & rngSource.Cells(1, 1).Value & "' WHERE F1 IS NOT NULL" Else MsgBox "فشل في فتح الاتصال بالملف: " & filePath, vbExclamation, "خطأ في الاتصال" End If conn.Close Set conn = Nothing End If Next i IsSyncing = False End Sub

رائع أ. محمود هذا هو المطلوب بعينه رضي الله عنك ووالديك

السلام عليكم الاساتذة الكرام أريد ناتج المعادلة أن كان رقم صحيح يظهر فقط الرقم الصحيح بدون خانة عشرية صفرية وان كان الناتج فيه رقم عشري يظهر الرقم العشري بخانة واحدة مع الرقم الصحيح مرفق مثال للتوضيح أكثر رقم عشري11.xlsm

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

الاساتذة الكرام السلام عليكم ورحمة الله ارجو المساعدة في كود منع اللصق إلا كقيم وتحويل أي لصق الى لصق قيم فقط حتى لا تفقد الخلايا تنسيقاتها السابقة Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Dim areas As Range Dim cell As Range ' إعداد النطاقات المتعددة Set areas = Union(Me.Range("C10:L109"), Me.Range("S10:S109"), Me.Range("V10:V109")) ' التعامل مع تغيير الخلايا On Error GoTo ClearApp Application.EnableEvents = False ' منع اللصق إلا كقيم Set rng = Intersect(Target, areas) If Not rng Is Nothing Then For Each cell In rng If cell.HasFormula Then cell.Value = cell.Value ' تحويل القيمة إلى قيمة ثابتة End If Next cell End If ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub لصق كقيم فقط.xlsm

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

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

مساء الخير استاذ أبو عيد المطلوب اساسا ان يعمل الكود على الخلايا باللون الازرق A1:P40 ولكن الذكاء الاصطناعي لم يستطع تخزين قيم الخلايا قبل الادخال إلا في خلايا موازيه Q1:AF40 والكود يعمل بصورة صحيحة في حالة CheckBox1 مفعل حيث تقوم الخلية الموازية بتخزين القيمة السابقة أما في حالة ازالة التفعيل من CheckBox1 فان الخلايا الموازية تكون محتفظة بالقيمة القديمة ولا تتغير مع اي ادخال في الخلايا المستهدفة وهكذا عندما تعود لتفعيل CheckBox1 يحدث خطأ كبير حيث يتم جمع القيمة المدخلة للخلية مع قيمة الخلية الموازية القديمة جدا حيث لم يقوم بتحديث القيم بعد ازالة تفعيل CheckBox1 ارجو لو امكن تلافي هذا الخلل بجعل قيم الخلايا الموازية تتحدث في حالة تفعيل أو عدم تفعيل CheckBox1 او الافضل من ذلك لو كود حضرتك الاول يستطيع ان يشمل النطاق المطلوب مع زر CheckBox1 أكون ممنون وشاكر وفقك الله لكل خير

الاساتذة الاجلاء بالاستعانة بكود الاستاذ أبو عيد مع الذكاء الاصطناعي تحصلت على الكود التالي ولكن احيانا لا يعمل الكود وايضا قد استعان الذكاء الاصطناعي باعمدة أخرى مماثلة لعدد الاعمدة المستهدفة ارجو لو امكن اختصار الكود وجعله مثل كود استاذنا ابو عيد فالذكاء البشرى أوعى وأفهم من الاصطناعي وجزاكم الله خيرا ‏‏جمع الخلية3.xlsm

استاذي الجليل أبو عيد الكود يعمل مية المية ولكن عندما حاولت توسيع نطاق الخلايا ليشمل (A1:P40) وايضا لو تكرمت أريد ربط عمل الكود بزر خيار أن كان مفعل يعمل وان لم يكن مفعل لا يعمل جمع الخلية2.xlsm

سلمت يداك في الدنيا والاخرة وسلمت يمين العزة والنصرة

أساتذتي الأجلاء الكرام السلام عليكم ورحمة الله ارجو المساعدة لتعديل كود جمع قيمة الادخال للخلية إلى قيمتها السابقة قبل الادخال وجزاكم الله خيرا مرفق ملف للتوضيح جمع الخلية لنفسها.xlsm