mahmoud nasr alhasany

جرب هذا الكود 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 Application.Undo ' التراجع عن اللصق الأصلي For Each cell In rng cell.Value = Target.Value ' لصق القيمة فقط Next cell End If ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub

رتيب البيانات: تمت إضافة lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row لتحديد آخر صف يحتوي على بيانات في العمود L (رصيد العميل). هذا يضمن أن الحلقة التالية تغطي جميع البيانات. إخفاء الصفوف: تمت إضافة حلقة For للتكرار على جميع الصفوف من 6 إلى lastRow. داخل الحلقة، يتم التحقق من قيمة رصيد العميل في العمود L. إذا كان الرصيد غير موجب (أقل من أو يساوي صفرًا)، يتم إخفاء الصف باستخدام .Rows(i).Hidden = True. إذا كان الرصيد موجبًا، يتم إظهار الصف باستخدام .Rows(i).Hidden = False (للتأكد من إظهار الصفوف التي قد تكون مخفية سابقًا). حساب إجمالي المديونية: تم استخدام الدالة WorksheetFunction.SumIf لحساب مجموع الأرصدة الموجبة فقط في النطاق L6:L75. تم تخزين النتيجة في المتغير totalDebt. عرض إجمالي المديونية: تمت إضافة السطر .Range("AI1").Value = "إجمالي المديونية: " تمت إضافة السطر . & totalDebt لعرض إجمالي المديونية في الخلية AH1. بللون الاحمر خط عريض وتنسيق القيمة بالجنية المصرى يمكنك تغيير الخلية حسب الحاجة. Sub ترتيب_وعرض_أرصدة_العملاء() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim totalDebt As Double Set ws = ThisWorkbook.Sheets("ورقة1") With ws ' 1. ترتيب البيانات تنازليًا حسب رصيد العميل .Range("A6:AH75").Sort Key1:=.Range("L6:L75"), Order1:=xlDescending, Header:=xlNo ' 2. إخفاء الصفوف التي تحتوي على أرصدة غير موجبة أو تساوي صفرًا lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row For i = 6 To lastRow If .Cells(i, "L").Value <= 0 Then .Rows(i).Hidden = True Else .Rows(i).Hidden = False End If Next i ' 3. حساب إجمالي المديونية totalDebt = WorksheetFunction.SumIf(.Range("L6:L75"), ">0") ' 4. عرض إجمالي المديونية .Range("AI1").Value = "إجمالي المديونية: " .Range("AH1").Value = totalDebt .Range("AH1").NumberFormat = "#,##0.00 ""ج.م""" ' تنسيق مخصص ' 5. تنسيق الخلية AH1 With .Range("AH1") .Font.Color = RGB(255, 0, 0) ' تعيين لون الخط إلى الأحمر .Font.Bold = True ' تعيين الخط إلى عريض End With End With End Sub مديونية 2025م(1).xls

ماذالت المشكلة قائمة فى عرض التقارير والخصومات حضور وانصراف 1.xlsm

مشكلة فى عرض تقرير حضور وانصراف بصيغة word/pdf حضور وانصراف 1.xlsm

جرب احدى البرنامجين ده بس حاول تعمل ايميل على اوتلوك برنامج SEND EMAIL.xlsb Send Email (VBA) - Copy.xlsm

جرب هذا الكود تحليل الكود: يقوم الكود بحساب مدة الالتزامات بناءً على شهور البداية والنهاية الموجودة في ورقة عمل Excel، ثم يحسب المدة الإجمالية والمتبقية. الخطوات: تحديد ورقة العمل: يتم تحديد ورقة العمل المسماة "Sheet1" (يمكنك تغييرها حسب الحاجة). حساب مدد الالتزامات: يتم المرور على كل صف في العمود "A" (بدءًا من الصف الثاني). يتم استخراج شهور البداية والنهاية من العمودين "D" و "F" على التوالي. يتم حساب المدة لكل التزام (شهر النهاية - شهر البداية + 1) وتخزينها في العمود "H". يتم حساب المدة الإجمالية لكل الالتزامات. حساب المدة المتبقية: يتم حساب المدة المتبقية بطرح المدة الإجمالية من 240. كتابة النتائج: يتم كتابة المدة الإجمالية والمدة المتبقية في الصفوف التالية لآخر صف مستخدم في العمود "A". رسالة تأكيد: يتم عرض رسالة تأكيد للمستخدم. Sub RoundedRectangle6_Click() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim totalDuration As Long Dim remainingDuration As Long Dim startMonth As Long Dim endMonth As Long ' تحديد ورقة العمل Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك ' حساب مدد الالتزامات lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow startMonth = Val(ws.Cells(i, "D").Value) endMonth = Val(ws.Cells(i, "F").Value) ws.Cells(i, "H").Value = endMonth - startMonth + 1 totalDuration = totalDuration + ws.Cells(i, "H").Value Next i ' حساب المدة المتبقية remainingDuration = 240 - totalDuration ' كتابة المدة الإجمالية والمدة المتبقية ws.Cells(lastRow + 2, "A").Value = "المدة الإجمالية:" ws.Cells(lastRow + 2, "B").Value = totalDuration ws.Cells(lastRow + 3, "A").Value = "المدة المتبقية:" ws.Cells(lastRow + 3, "B").Value = remainingDuration ' رسالة تأكيد MsgBox "تم إنشاء الجدول وحساب المدد." End Sub

نعم، أنت محق .ahrambakr بما أن الملف معى يعمل بشكل صحيح ، فالمشكلة بالتأكيد تتعلق بإعدادات نظام التشغيل أو Excel لديك. إليك بعض الخطوات التي يمكنك اتخاذها لحل المشكلة: 1. التحقق من إعدادات اللغة في نظام التشغيل: منطقة اللغة: تأكد من أن "المنطقة" في إعدادات Windows مضبوطة على بلد يستخدم اللغة العربية كلغة أساسية. اذهب إلى "إعدادات" -> "الوقت واللغة" -> "المنطقة". اللغات: تأكد من إضافة اللغة العربية إلى قائمة اللغات المفضلة. اذهب إلى "إعدادات" -> "الوقت واللغة" -> "اللغة". 2. التحقق من إعدادات اللغة في Excel: خيارات اللغة: افتح Excel واذهب إلى "ملف" -> "خيارات" -> "اللغة". تأكد من أن اللغة العربية هي اللغة الافتراضية للعرض والتحرير. خيارات متقدمة: في "خيارات" -> "متقدم"، تحقق من إعدادات "عرض" و"تحرير" المتعلقة باللغات. 3. التحقق من خطوط الكتابة: تنسيق الخلايا: حدد الخلايا التي تحتوي على النص الذي يظهر بشكل غير صحيح. انقر بزر الماوس الأيمن واختر "تنسيق الخلايا". في علامة التبويب "خط"، تأكد من اختيار خط يدعم اللغة العربية بشكل كامل (مثل Arial أو Times New Roman). 4. إعادة تشغيل الجهاز: في بعض الأحيان، قد تتطلب تغييرات إعدادات اللغة إعادة تشغيل الجهاز لتطبيقها بشكل كامل. 5. تحديث Excel: تأكد من أن لديك أحدث إصدار من Excel مثبتًا. قد تحتوي التحديثات على إصلاحات لمشاكل توافق اللغة. 6. تجربة على جهاز آخر: إذا استمرت المشكلة، حاول فتح الملف على جهاز آخر بإعدادات لغة مختلفة لمعرفة ما إذا كانت المشكلة خاصة بجهازك. ملاحظات إضافية: قد يكون هناك تعارض بين بعض إعدادات اللغة في Windows و Excel. قد تكون هناك بعض الملفات المؤقتة التالفة التي تسبب هذه المشكلة. إذا كنت تستخدم إصدارًا قديمًا جدًا من Excel، فقد تواجه مشاكل في توافق اللغة. آمل أن تساعدك هذه الخطوات في حل المشكلة.ahrambakr

اريد ان ترفق الملف لحل طلبك

هذا الكود لتحويل الأرقام إلى كلمات في العمود B عند إدخال قيمة في العمود A، مع مراعاة اللغة العربية والعملة (الجنيه المصري). شرح الكود: Worksheet_Change: هذا الإجراء يتم تشغيله تلقائيًا عند تغيير أي خلية في ورقة العمل. Tafqit: هذه الدالة الرئيسية تقوم بتحويل الرقم إلى نص، مع مراعاة الجزء الصحيح والجزء العشري. TafqitInteger: هذه الدالة تقوم بتحويل الجزء الصحيح من الرقم إلى نص. TafqitGroup: هذه الدالة تقوم بتحويل مجموعة من ثلاثة أرقام إلى نص (مئات، آلاف، ملايين). ملاحظات هامة: هذا الكود يدعم الأرقام الصحيحة والأرقام العشرية. تمت إضافة دعم للغة العربية والعملة (الجنيه المصري). يمكنك تعديل الكود لتغيير العملة أو لإضافة دعم لعملات أخرى. الكود يعمل علي القيم الموجبة فقط. يمكن إضافة بعض التعديلات علي الكود لتحسينه. آمل أن يكون هذا الكود مفيدًا! Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range 'تحديد العمود الذي سيتم مراقبته (العمود A) If Not Intersect(Target, Columns("A")) Is Nothing Then 'المرور على الخلايا التي تم تغييرها For Each cell In Target 'التحقق من أن الخلية تحتوي على قيمة رقمية If IsNumeric(cell.Value) Then 'استدعاء دالة التفقيط ووضع النتيجة في العمود B cell.Offset(0, 1).Value = Tafqit(cell.Value) End If Next cell End If End Sub Function Tafqit(ByVal num As Double) As String Dim strNum As String Dim parts As Variant Dim intPart As Long Dim decPart As Long Dim result As String 'فصل الجزء الصحيح والجزء العشري strNum = Format(num, "0.00") parts = Split(strNum, ".") intPart = CLng(parts(0)) decPart = CLng(parts(1)) 'تفقيط الجزء الصحيح result = TafqitInteger(intPart) 'إضافة كلمة "جنيه" If intPart > 0 Then result = result & " جنيه" End If 'تفقيط الجزء العشري If decPart > 0 Then result = result & " و " & TafqitInteger(decPart) & " قرش" End If Tafqit = result End Function Function TafqitInteger(ByVal num As Long) As String Dim units As Variant, tens As Variant, hundreds As Variant Dim groups(2) As Long Dim result As String Dim i As Integer units = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") hundreds = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") groups(0) = num Mod 1000 groups(1) = (num \ 1000) Mod 1000 groups(2) = num \ 1000000 For i = 2 To 0 Step -1 If groups(i) > 0 Then result = result & " " & TafqitGroup(groups(i), i) End If Next i TafqitInteger = Trim(result) End Function Function TafqitGroup(ByVal num As Long, ByVal groupIndex As Integer) As String Dim units As Variant, tens As Variant, hundreds As Variant Dim result As String units = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") hundreds = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") If num >= 100 Then result = result & hundreds(num \ 100) & " " num = num Mod 100 End If If num >= 20 Then result = result & tens(num \ 10) & " " & units(num Mod 10) ElseIf num >= 10 Then result = result & units(num) Else result = result & units(num) End If Select Case groupIndex Case 1 If num > 0 Then result = result & " ألف" Case 2 If num > 0 Then result = result & " مليون" End Select TafqitGroup = Trim(result) End Function صيغة تفقيط.xlsm

المشكلة التي تواجهك في VBA Excel عند تحويل الأرقام إلى كلمات وظهور علامات استفهام أو حروف غير مفهومة، هي مشكلة شائعة تتعلق بترميز الأحرف (Encoding) في VBA. إليك شرح للمشكلة وحلولها: سبب المشكلة: ترميز الأحرف: VBA يستخدم ترميزًا معينًا للأحرف، وأحيانًا لا يتوافق هذا الترميز مع الترميز المستخدم في النص الذي تحاول تحويله. عندما يكون هناك عدم توافق في الترميز، تظهر الأحرف بشكل غير صحيح، مثل علامات الاستفهام أو الرموز الغريبة. إعدادات اللغة: إعدادات اللغة في نظام التشغيل وفي Excel يمكن أن تؤثر على كيفية عرض الأحرف. إذا كانت إعدادات اللغة غير متوافقة، فقد تظهر الأحرف بشكل غير صحيح. حلول المشكلة: استخدام ترميز UTF-8: UTF-8 هو ترميز عالمي يدعم معظم اللغات، بما في ذلك اللغة العربية. يمكنك محاولة تحويل النص إلى ترميز UTF-8 قبل عرضه في Excel. هذا الحل يحتاج الي تعديل الكود المسئول عن تحويل الارقام الي نص. تغيير إعدادات اللغة في Excel: تأكد من أن إعدادات اللغة في Excel متوافقة مع اللغة العربية. يمكنك التحقق من ذلك من خلال: ملف > خيارات > اللغة. تأكد من أن اللغة العربية هي اللغة الافتراضية. تغيير إعدادات اللغة في نظام التشغيل: تأكد من أن إعدادات اللغة في نظام التشغيل متوافقة مع اللغة العربية. يمكنك التحقق من ذلك من خلال: لوحة التحكم > المنطقة واللغة. استخدام دوال تحويل الأرقام إلى كلمات جاهزة: هناك بعض الدوال الجاهزة التي يمكن استخدامها لتحويل الأرقام إلى كلمات باللغة العربية. قد تكون هذه الدوال أكثر موثوقية من الدوال المخصصة التي قد تواجه مشاكل في الترميز. يوجد الكثير من الاكواد الجاهزة علي الانترنت التي تقوم بنفس الغرض. التأكد من خطوط الكتابة: بعض الخطوط لا تدعم اللغة العربية بشكل كامل, لذلك يجب التأكد من الخط المستخدم داخل ملف الاكسل يدعم اللغة العربية. نصائح إضافية: إذا كنت تستخدم دالة مخصصة لتحويل الأرقام إلى كلمات، فحاول البحث عن تحديثات أو إصلاحات لهذه الدالة. إذا كنت تستخدم دالة خارجية، فتأكد من أنها متوافقة مع إصدار Excel الذي تستخدمه. تاكد من حفظ ملف الاكسل بصيغة تدعم اللغة العربية بشكل كامل. آمل أن تساعدك هذه الحلول في حل المشكلة الرجاء ان ترفق الملف اذا لم تنجح معك الحلول السابقة للمساعدتك

تفضل ورقة ارسال عن طريق الواتس اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm

Sub StringSort() Dim WS As Worksheet Dim lastRow As Long Dim sortRange As Range ' اسم ورقة العمل (يمكن تغييره) Const SHEET_NAME As String = "Sheet1" Application.ScreenUpdating = False ' التحقق من وجود ورقة العمل On Error Resume Next Set WS = ThisWorkbook.Sheets(SHEET_NAME) On Error GoTo 0 If WS Is Nothing Then MsgBox "ورقة العمل '" & SHEET_NAME & "' غير موجودة.", vbExclamation GoTo Cleanup End If ' العثور على الصف الأخير في العمود A lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row ' التحقق من وجود بيانات If lastRow < 2 Then MsgBox "لا توجد بيانات للفرز.", vbExclamation GoTo Cleanup End If ' تحديد نطاق الفرز Set sortRange = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear With .SortFields .Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending .Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending End With .SetRange sortRange .Header = xlYes .Apply End With Cleanup: Application.ScreenUpdating = True End Sub

إليك كود VBA في Excel لتحقيق ذلك، مع شرح تفصيلي: شرح الكود المتغيرات: lastRow: لتحديد آخر صف يحتوي على بيانات في العمود A (يمكنك تغيير العمود حسب الحاجة). i: متغير يستخدم في حلقة التكرار للمرور على الصفوف. endDate: لتخزين تاريخ انتهاء العقد. daysRemaining: لحساب عدد الأيام المتبقية حتى انتهاء العقد. emailAddress: لتخزين عنوان البريد الإلكتروني للشخص المعني. messageBody: لتخزين نص الرسالة. حلقة التكرار: تكرر الحلقة على جميع الصفوف التي تحتوي على بيانات. تفترض أن تاريخ انتهاء العقد موجود في العمود B، وأن عنوان البريد الإلكتروني موجود في العمود C، ونص الرسالة موجود في العمود D. يمكنك تغيير هذه الأعمدة حسب الحاجة. يتم حساب عدد الأيام المتبقية حتى انتهاء العقد باستخدام الدالة DateDiff. إذا كان عدد الأيام المتبقية 60 يومًا أو أقل، يتم تنفيذ الخطوات التالية: جلب عنوان البريد الإلكتروني ونص الرسالة. استخدام CreateObject("Outlook.Application") لإرسال البريد الإلكتروني. تحديد عنوان المرسل إليه، الموضوع، ونص الرسالة. عرض البريد الإلكتروني أو إرساله مباشرةً. إرسال واتساب: تتطلب هذه الخطوة استخدام واجهة برمجة تطبيقات (API) خاصة بـ WhatsApp، حيث لا يوجد طريقة مباشرة لإرسال رسائل WhatsApp باستخدام VBA فقط. يمكنك استخدام خدمات مثل Twilio أو MessageBird أو غيرها لإرسال رسائل WhatsApp عبر API. يجب عليك التسجيل في إحدى هذه الخدمات والحصول على مفتاح API. يمكنك استخدام الدالة CreateObject("MSXML2.XMLHTTP") لإرسال طلب HTTP إلى API الخاص بـ WhatsApp. الكود ملاحظات: تأكد من تغيير أسماء الأعمدة في الكود لتتوافق مع بياناتك. لتفعيل إرسال الايميل يجب تفعيل المكتبة الخاصة ب outlook من قائمة tools ثم references ثم اختيار Microsoft outlook Object Library. لإرسال رسائل WhatsApp، ستحتاج إلى إضافة كود إضافي باستخدام API. يمكنك تخصيص نص الرسالة وموضوع البريد الإلكتروني حسب الحاجة. يمكنك جدولة تشغيل هذا الكود تلقائيًا باستخدام وظيفة "جدولة المهام" في Windows. إضافة كود لإرسال رسائل WhatsApp باستخدام API يتطلب بعض الخطوات الإضافية. إليك شرح لكيفية القيام بذلك باستخدام خدمة Twilio، وهي واحدة من الخدمات الشائعة التي توفر واجهة برمجة تطبيقات (API) لإرسال رسائل WhatsApp: 1. التسجيل في Twilio والحصول على مفتاح API: قم بزيارة موقع Twilio وقم بإنشاء حساب. بعد تسجيل الدخول، انتقل إلى وحدة تحكم Twilio واحصل على مفتاح API الخاص بك (Account SID وAuth Token). قم بتمكين WhatsApp في حساب Twilio الخاص بك. احصل على رقم هاتف Twilio يدعم WhatsApp. 2. إضافة مكتبة MSXML2: في محرر VBA، انتقل إلى "Tools" ثم "References". ابحث عن "Microsoft XML, v6.0" أو إصدار أحدث وقم بتحديده. 3. كود VBA لإرسال رسالة WhatsApp: Sub SendEmailOrWhatsApp() Dim lastRow As Long Dim i As Long Dim endDate As Date Dim daysRemaining As Long Dim emailAddress As String Dim messageBody As String lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A For i = 2 To lastRow ' ابدأ من الصف الثاني (بافتراض أن الصف الأول هو رأس الجدول) endDate = Cells(i, "B").Value ' تاريخ انتهاء العقد في العمود B daysRemaining = DateDiff("d", Date, endDate) ' حساب الأيام المتبقية emailAddress = Cells(i, "C").Value ' عنوان البريد الإلكتروني في العمود C messageBody = Cells(i, "D").Value ' نص الرسالة في العمود D If daysRemaining <= 60 Then ' إرسال بريد إلكتروني Dim outlookApp As Object Dim outlookMail As Object Set outlookApp = CreateObject("Outlook.Application") Set outlookMail = outlookApp.CreateItem(0) With outlookMail .To = emailAddress .Subject = "تنبيه: انتهاء العقد" .Body = messageBody .Display ' أو .Send للإرسال مباشرةً End With Set outlookMail = Nothing Set outlookApp = Nothing ' إرسال واتساب (يتطلب استخدام API) ' يمكنك إضافة كود لإرسال واتساب هنا باستخدام API End If Next i End Sub Sub SendWhatsAppMessage(phoneNumber As String, messageBody As String) Dim xmlHttp As Object Dim accountSid As String Dim authToken As String Dim twilioNumber As String Dim url As String accountSid = "ACxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' استبدل بـ Account SID الخاص بك authToken = "your_auth_token" ' استبدل بـ Auth Token الخاص بك twilioNumber = "whatsapp:+1xxxxxxxxxx" ' استبدل برقم Twilio الخاص بك phoneNumber = "whatsapp:+xxxxxxxxxxx" ' استبدل برقم هاتف المستلم url = "https://api.twilio.com/2010-04-01/Accounts/" & accountSid & "/Messages.json" Set xmlHttp = CreateObject("MSXML2.XMLHTTP") xmlHttp.Open "POST", url, False xmlHttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(accountSid & ":" & authToken) xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" xmlHttp.send "To=" & phoneNumber & "&From=" & twilioNumber & "&Body=" & EncodeUrl(messageBody) If xmlHttp.Status = 201 Then MsgBox "تم إرسال رسالة WhatsApp بنجاح!" Else MsgBox "فشل إرسال رسالة WhatsApp. الحالة: " & xmlHttp.Status End If Set xmlHttp = Nothing End Sub Function EncodeBase64(text As String) As String Dim arrData() As Byte arrData = StrConv(text, vbFromUnicode) Dim objXML As Object Dim objNode As Object Set objXML = CreateObject("MSXML2.DOMDocument") Set objNode = objXML.createElement("b64") objNode.DataType = "bin.base64" objNode.nodeTypedValue = arrData EncodeBase64 = objNode.text Set objNode = Nothing Set objXML = Nothing End Function Function EncodeUrl(text As String) As String Dim objXML As Object Set objXML = CreateObject("MSXML2.DOMDocument") EncodeUrl = objXML.createElement("url").appendChild(objXML.createTextNode(text)).ParentNode.innerHTML Set objXML = Nothing End Function

تم عمل استعلام موظف Sub بحث_في_السجل() Dim wsSijel As Worksheet, wsBataka As Worksheet Dim startDate As Date, endDate As Date Dim employeeName As String, movementType As String Dim i As Long, j As Long Dim lastRowSijel As Long, lastRowBataka As Long 'تعيين أوراق العمل Set wsSijel = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة 'قراءة قيم البحث من بطاقة الموظف startDate = wsBataka.Range("A2").Value endDate = wsBataka.Range("B2").Value employeeName = wsBataka.Range("C2").Value movementType = wsBataka.Range("D2").Value 'مسح البيانات القديمة في بطاقة الموظف lastRowBataka = wsBataka.Cells(wsBataka.Rows.Count, "A").End(xlUp).Row If lastRowBataka >= 6 Then wsBataka.Range("A6:F" & lastRowBataka).ClearContents End If 'إيجاد آخر صف في شيت السجل lastRowSijel = wsSijel.Cells(wsSijel.Rows.Count, "A").End(xlUp).Row 'البحث في السجل وعرض البيانات في بطاقة الموظف j = 6 'بداية كتابة البيانات في بطاقة الموظف من الصف 6 For i = 2 To lastRowSijel 'بداية البحث من الصف 2 (تخطي العناوين) If wsSijel.Cells(i, 2).Value = employeeName And _ wsSijel.Cells(i, 4).Value = movementType And _ wsSijel.Cells(i, 5).Value >= startDate And _ wsSijel.Cells(i, 5).Value <= endDate Then 'كتابة البيانات في بطاقة الموظف wsBataka.Cells(j, 1).Value = wsSijel.Cells(i, 1).Value 'العمود الأول wsBataka.Cells(j, 2).Value = wsSijel.Cells(i, 2).Value 'اسم الموظف wsBataka.Cells(j, 3).Value = wsSijel.Cells(i, 5).Value 'العمود الثالث wsBataka.Cells(j, 4).Value = wsSijel.Cells(i, 6).Value 'نوع الحركة wsBataka.Cells(j, 5).Value = wsSijel.Cells(i, 7).Value 'التاريخ wsBataka.Cells(j, 6).Value = wsSijel.Cells(i, 8).Value 'العمود السادس wsBataka.Cells(j, 6).NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود j = j + 1 'زيادة الصف لكتابة البيانات في الصف التالي End If Next i MsgBox "تم البحث وعرض البيانات بنجاح." 'Call حساب_مجموع_الساعات Call جمع_الساعات_والدقائق End Sub Sub جمع_الساعات_والدقائق() Dim wsBataka As Worksheet Dim نطاق_الجمع As Range Dim مجموع_الوقت As Double Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة ' تحديد نطاق الجمع (F6 إلى آخر خلية في العمود F) Set نطاق_الجمع = Range("F6", Cells(Rows.Count, "F").End(xlUp)) ' جمع القيم في النطاق مجموع_الوقت = WorksheetFunction.Sum(نطاق_الجمع) ' وضع النتيجة في الخلية E4 Range("E4").Value = مجموع_الوقت ' تنسيق الخلية E4 Range("E4").NumberFormat = "[h]:mm" ' أو "h:mm" حسب الحاجة End Sub الخروج والعودة - كود.xlsm

هل هذا هو المطلوب Sub حساب_فرق_الساعات1() Dim wsData As Worksheet, wsSummary As Worksheet Dim lastRowData As Long, lastRowSummary As Long Dim i As Long, j As Long Dim employeeName As String, movementType As String, movementDate As Date Dim exitTime As Date, returnTime As Date, timeDifference As Double Dim totalHours As Double, days As Long, remainingHours As Long Dim summaryDict As Object 'استخدام Dictionary لتجميع الساعات حسب الموظف والشهر 'تعيين ورقتي العمل Set wsData = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsSummary = ThisWorkbook.Sheets("احتساب عدد الساعات") 'تغيير اسم الورقة حسب الحاجة 'إيجاد آخر صف في ورقة البيانات lastRowData = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row 'إضافة عناوين الأعمدة في ورقة الملخص wsSummary.Cells(1, "A").Value = "اسم الموظف" wsSummary.Cells(1, "C").Value = "نوع الحركة (زمنية)" wsSummary.Cells(1, "D").Value = "إجمالي عدد الساعات" wsSummary.Cells(1, "F").Value = "عدد الأيام والساعات المتبقية" 'إنشاء Dictionary لتجميع الساعات Set summaryDict = CreateObject("Scripting.Dictionary") 'حساب الفرق بين وقت الخروج ووقت العودة For i = 2 To lastRowData employeeName = wsData.Cells(i, "B").Value movementType = wsData.Cells(i, "D").Value movementDate = wsData.Cells(i, "E").Value exitTime = wsData.Cells(i, "F").Value returnTime = wsData.Cells(i, "G").Value 'تأكد من وجود وقت خروج ووقت عودة If IsDate(exitTime) And IsDate(returnTime) Then timeDifference = returnTime - exitTime wsData.Cells(i, "H").Value = timeDifference wsData.Cells(i, "H").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تجميع الساعات إذا كانت الحركة "زمنية" If movementType = "زمنية" Then Dim key As String key = employeeName ' استخدام اسم الموظف فقط كمفتاح If summaryDict.Exists(key) Then summaryDict(key) = summaryDict(key) + timeDifference Else summaryDict(key) = timeDifference End If End If End If Next i 'كتابة ملخص الساعات في ورقة الملخص j = 2 Dim key1 As Variant For Each key1 In summaryDict.Keys employeeName = key1 ' استخدام المفتاح مباشرةً كاسم الموظف totalHours = summaryDict(key1) 'كتابة البيانات في ورقة الملخص wsSummary.Cells(j, "A").Value = employeeName wsSummary.Cells(j, "C").Value = "زمنية" wsSummary.Cells(j, "D").Value = totalHours wsSummary.Cells(j, "D").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تحويل الساعات إلى أيام وساعات days = Int(totalHours * 24 / 24) remainingHours = (totalHours * 24) Mod 24 wsSummary.Cells(j, "F").Value = days & " يوم " & remainingHours & " ساعة" j = j + 1 Next key1 MsgBox "تم حساب الفرق بين وقت الخروج ووقت العودة وتلخيص الساعات بنجاح." End Sub الخروج والعودة - كود.xlsm

الف شكر لك ا / محمد هشام هذا هو المطلوب عمله

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

الف شكر استاذنا / محمد هشام هذا هو المطلوب هل يمكن اضافة \تنسيق الأرقام فى كود الصنف على ورقة الوورد بحيث تظهر دائمًا بخمسة أرقام مع إضافة أصفار في البداية إذا لزم الأمر (مثل 00245، 02458، 231456) لقد فعلت هذا الخيار ولم يفلح الامر For i = LBound(a) To UBound(a) ' تعديل هنا: تحويل الرقم إلى نص ثم تنسيقه d(i) = Array(a(i, 1), Format(CStr(a(i, 3)), "00000"), a(i, 4), a(i, 6), a(i, 8)) Next i

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

تمام احسنت الف شكر لك استاذنا الفاضل / محمد هشام

السلام عليكم ورحمة الله وبركاتة يوجد مشكلة فى الكود اريد التعديل على الكود للتعامل مع عدة ملفات مصدر بدلاً من ملف واحد وهى نقل البيانات من عدة ملفات مصدر إلى ملف وجهة واحد. Sub نقل_البيانات_بين_الملفات_محسن() ' تعريف المتغيرات Dim wbDest As Workbook, wbSource As Workbook Dim wsDest As Worksheet, wsSource As Worksheet Dim lastRowDest As Long Dim i As Long, j As Long Dim sourceData As Variant, wsName As String Dim filePath As String Dim fileNames As Variant ' مصفوفة لتخزين أسماء الملفات Dim fileName As Variant Dim sheetNames As Variant Dim sheetName As Variant Dim headers As Variant Dim محافظة As String Dim dataDict As Object ' تعطيل تحديث الشاشة والحساب التلقائي لتسريع التنفيذ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' تعيين ملف الوجهة (الملف الحالي) Set wbDest = ThisWorkbook ' مصفوفة أسماء الملفات المصدر (يمكنك تعديل هذه القائمة) fileNames = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _ "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _ "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _ "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _ "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _ "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _ "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _ "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _ "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _ "رصيد التوكيلات_ادفو.xlsx") ' مصفوفة أسماء الأوراق المطلوبة (المحافظات) - يجب أن تتطابق مع أسماء الأوراق في الملفات المصدر sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو") ' إنشاء قاموس لتخزين البيانات من الملفات المصدر Set dataDict = CreateObject("Scripting.Dictionary") ' المرور على كل ملف من ملفات المصدر For Each fileName In fileNames ' بناء مسار الملف الكامل filePath = ThisWorkbook.Path & "\" & fileName ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next ' تخطي الخطأ إذا كان الملف مفتوحًا بالفعل Set wbSource = Workbooks(fileName) On Error GoTo 0 If wbSource Is Nothing Then ' إذا لم يتم العثور على الملف المفتوح On Error Resume Next ' تخطي الخطأ إذا لم يتم العثور على الملف Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then ' إذا لم يتم فتح الملف MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical GoTo SkipFile ' الانتقال إلى الملف التالي End If End If ' المرور على أوراق العمل في الملف المصدر For Each wsSource In wbSource.Sheets محافظة = wsSource.Name ' قراءة البيانات والعناوين من ورقة العمل sourceData = wsSource.Range("B3:S71").Value headers = wsSource.Range("F3:S3").Value ' تخزين البيانات في القاموس باستخدام اسم المحافظة كمفتاح If Not dataDict.Exists(محافظة) Then dataDict.Add محافظة, sourceData End If Next wsSource ' إغلاق الملف المصدر بعد الانتهاء من قراءة البيانات منه wbSource.Close SaveChanges:=False SkipFile: ' علامة لتخطي الملف في حالة عدم وجوده Next fileName ' الآن، dataDict يحتوي على البيانات من جميع الملفات ' المرور على أسماء المحافظات لنقل البيانات إلى الملف الوجهة For Each sheetName In sheetNames ' البحث عن ورقة العمل في ملف الوجهة، وإنشائها إذا لم تكن موجودة On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If ' كتابة العناوين في ورقة العمل إذا كانت فارغة If wsDest.Cells(1, 6).Value = "" Then wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers End If ' إذا كانت البيانات موجودة في القاموس، انقلها إلى ورقة العمل If dataDict.Exists(sheetName) Then sourceData = dataDict(sheetName) ' تحديد الصف الأخير في ورقة العمل lastRowDest = wsDest.Cells(Rows.Count, "F").End(xlUp).Row + 1 ' تعديل لايجاد اخر صف ' تجهيز البيانات للنقل (تخطي الأعمدة من 1 إلى 4) Dim outputData As Variant ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4) For i = 1 To UBound(sourceData, 1) For j = 5 To UBound(sourceData, 2) outputData(i, j - 4) = sourceData(i, j) Next j Next i ' نقل البيانات إلى ورقة العمل wsDest.Range("F" & lastRowDest).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData End If Next sheetName ' استعادة إعدادات Excel Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نقل البيانات بنجاح.", vbInformation End Sub نقل البيانات بين الملفات.rar

لقد وجدت الحل ايضا واشكر استاذنا / محمد هشام على مساعدتنا فى حل المشكلة وارجح كود ا / محمد هشام Sub نقل_البيانات_بين_الملفات_محسن() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowDest As Long Dim i As Long, j As Long Dim sourceData As Variant, wsName As String Dim filePath As String Dim sheetNames As Variant Dim sheetName As Variant Dim headers As Variant Dim محافظة As String Dim dataDict As Object ' قاموس لتخزين البيانات Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set wbDest = ThisWorkbook filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' مصفوفة أسماء الأوراق المطلوبة sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو") ' إنشاء قاموس لتخزين البيانات Set dataDict = CreateObject("Scripting.Dictionary") For Each wsSource In wbSource.Sheets محافظة = wsSource.Name sourceData = wsSource.Range("B3:S71").Value headers = wsSource.Range("F3:S3").Value ' تخزين البيانات في القاموس dataDict.Add محافظة, sourceData Next wsSource For Each sheetName In sheetNames On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 lastRowDest = 3 ' ابدأ من الصف الثالث If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If If wsDest.Cells(1, 6).Value = "" Then wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers End If If dataDict.Exists(sheetName) Then sourceData = dataDict(sheetName) ' تعديل هنا: تحديد الصف الأخير داخل النطاق F3:S71 lastRowDest = wsDest.Range("F3:F71").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row '+ 1 ' التحقق من وجود اسم المحافظة في مصفوفة sheetNames If IsError(Application.Match(sheetName, sheetNames, 0)) Then ' إذا لم يتم العثور على اسم المحافظة، تخطي هذا الصف Debug.Print "تحذير: اسم المحافظة '" & sheetName & "' غير موجود في قائمة المحافظات." GoTo SkipRow ' انتقل إلى الصف التالي End If Dim outputData As Variant ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4) For i = 1 To UBound(sourceData, 1) For j = 5 To UBound(sourceData, 2) outputData(i, j - 4) = sourceData(i, j) Next j Next i SkipRow: ' تسمية العلامة لتخطي الصف في حالة عدم تطابق اسم المحافظة wsDest.Range("F" & lastRowDest).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData End If Next sheetName wbSource.Close SaveChanges:=False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

هل يوجد احد بأمكانة مساعدتى

لقد وجدت الحل ولاكن توجد مشكلة وهى ان استدعاء البيانات بيأخذ وقت كتير لكثرة اوراق العمل هل يوجد كود بديل واسرع من هذا الكود Sub نقل_البيانات_بين_الملفات46() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowSource As Long, lastColSource As Long Dim lastRowDest As Long Dim i As Long, j As Long, k As Long Dim itemCode As String, monthDate As String Dim sourceData As Variant, wsName As String Dim filePath As String Dim wsFoundSource As Boolean Dim sheetNames As Variant Dim sheetName As Variant ' متغير لحلقة التكرار على الأوراق Dim headers As Variant ' متغير لتخزين العناوين Dim محافظة As String Set wbDest = ThisWorkbook ' تحديد مسار الملف المصدر filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' مصفوفة أسماء الأوراق المطلوبة (عدّل هذه الأسماء) sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو") ' تكرار على أوراق العمل في ملف المصدر For Each wsSource In wbSource.Sheets ' الحصول على اسم المحافظة من اسم ورقة العمل محافظة = wsSource.Name ' قراءة البيانات من ورقة العمل الحالية إلى مصفوفة لتسريع العملية sourceData = wsSource.Range("B3:S71").Value ' يشمل كود الصنف والمحافظة ' تخزين العناوين في متغير headers = wsSource.Range("F3:S3").Value ' تكرار على أسماء الأوراق الهدف For Each sheetName In sheetNames ' البحث عن الورقة المطلوبة في ملف الوجهة On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 ' إذا لم يتم العثور على الورقة في ملف الوجهة، قم بإنشائها If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If ' الآن wsDest يشير إلى ورقة العمل الصحيحة، سواء كانت موجودة أو تم إنشاؤها ' تحديد الصف الأخير في ورقة العمل الوجهة بطريقة أكثر دقة lastRowDest = 2 ' ابدأ من الصف الثاني (بعد العناوين) ' كتابة العناوين في ورقة العمل الوجهة (مرة واحدة فقط) ' **فحص ما إذا كانت العناوين موجودة بالفعل قبل كتابتها** If wsDest.Cells(1, 6).Value = "" Then ' إذا كانت الخلية فارغة، فهذا يعني أن العناوين غير موجودة wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers ' كتابة العناوين في الصف الأول، بدءًا من العمود F End If ' إدخال البيانات في ورقة العمل الوجهة If Not IsEmpty(sourceData) Then ' نقل البيانات من المصفوفة إلى ورقة العمل For i = 1 To UBound(sourceData, 1) ' الصفوف في المصفوفة ' التحقق من وجود اسم المحافظة في مصفوفة sheetNames If IsError(Application.Match(محافظة, sheetNames, 0)) Then ' إذا لم يتم العثور على اسم المحافظة، تخطي هذا الصف Debug.Print "تحذير: اسم المحافظة '" & محافظة & "' غير موجود في قائمة المحافظات." GoTo SkipRow ' انتقل إلى الصف التالي End If ' التحقق من تطابق اسم المحافظة مع اسم ورقة العمل الهدف If محافظة = sheetName Then For j = 5 To UBound(sourceData, 2) ' الأعمدة في المصفوفة (من F إلى S) wsDest.Cells(lastRowDest + i, j + 1).Value = sourceData(i, j) ' ابدأ من العمود F (العمود 6) Next j End If SkipRow: ' تسمية العلامة لتخطي الصف في حالة عدم تطابق اسم المحافظة Next i End If Next sheetName Next wsSource ' انتهاء التكرار على أوراق العمل في ملف المصدر ' إغلاق الملف المصدر (اختياري) wbSource.Close SaveChanges:=False End Sub اعتقد ان هذا الكود اسرع ولاكن يقوم بنقل البيانات خارج الجدول لكل محافظ اريد نقل البيانات داخل الجدول مالخطاء هنا Sub نقل_البيانات_بين_الملفات46_محسّن() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowDest As Long Dim i As Long, j As Long Dim sourceData As Variant, wsName As String Dim filePath As String Dim sheetNames As Object ' Dictionary لتخزين أسماء الأوراق Dim sheetName As Variant Dim headers As Variant Dim محافظة As String Dim outputData As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set wbDest = ThisWorkbook filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' إنشاء Dictionary لتخزين أسماء الأوراق Set sheetNames = CreateObject("Scripting.Dictionary") sheetNames.Add "الاسكندرية", 1 sheetNames.Add "كفرالشيخ", 1 sheetNames.Add "البحيرة", 1 sheetNames.Add "طنطا", 1 sheetNames.Add "المنصورة", 1 sheetNames.Add "دكرنس", 1 sheetNames.Add "دمياط", 1 sheetNames.Add "المنوفية", 1 sheetNames.Add "الشرقية", 1 sheetNames.Add "الاسماعيلية", 1 sheetNames.Add "بور سعيد", 1 sheetNames.Add "السويس", 1 sheetNames.Add "المقطم", 1 sheetNames.Add "مؤسسة الزكاة", 1 sheetNames.Add "الجيزة", 1 sheetNames.Add "القليوبية", 1 sheetNames.Add "الفيوم", 1 sheetNames.Add "بنى سويف", 1 sheetNames.Add "المنيا", 1 sheetNames.Add "اسيوط", 1 sheetNames.Add "سوهاج", 1 sheetNames.Add "جرجا", 1 sheetNames.Add "قنا", 1 sheetNames.Add "نجع حمادى", 1 sheetNames.Add "الغردقة", 1 sheetNames.Add "الاقصر", 1 sheetNames.Add "اسوان", 1 sheetNames.Add "ادفو", 1 For Each wsSource In wbSource.Sheets محافظة = wsSource.Name ' استخدام النطاقات المُعرّفة (تأكد من تعريفها في ملف المصدر) On Error Resume Next ' للتعامل مع الأوراق التي قد لا تحتوي على نطاق مُعرّف sourceData = wsSource.Range("DataRange_" & محافظة).Value On Error GoTo 0 ' إذا لم يتم العثور على النطاق المُعرّف، استخدم النطاق الافتراضي If IsEmpty(sourceData) Then sourceData = wsSource.Range("B3:S71").Value End If headers = wsSource.Range("F3:S3").Value For Each sheetName In sheetNames.Keys On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 If wsDest Is Nothing Then Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count)) wsDest.Name = sheetName End If lastRowDest = wsDest.Cells(Rows.Count, "F").End(xlUp).Row + 1 If wsDest.Cells(1, 6).Value = "" Then ' إذا كانت الخلية فارغة، فهذا يعني أن العناوين غير موجودة wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers ' كتابة العناوين في الصف الأول، بدءًا من العمود F End If ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4) If Not IsEmpty(sourceData) Then For i = 1 To UBound(sourceData, 1) If محافظة = sheetName Then For j = 5 To UBound(sourceData, 2) outputData(i, j - 4) = sourceData(i, j) Next j End If Next i wsDest.Cells(lastRowDest, 6).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData End If Next sheetName Next wsSource wbSource.Close SaveChanges:=False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub رصيد التوكيلات1.xlsx رصيد التوكيلات.xlsm

السلام عليكم ورحمة الله وبركاته اريد المساعدة يوجد خطاء فى الكود نقل البيانات من ملف "رصيد التوكيلات1.xlsx" الى ملف "رصيد التوكيلات. XLM" على حسب كود الصنف من B3:B71 وصف التاريخ من F3:S3 والبيانات التابعة لكل صنف من F4:S71 فى ورقة شيت كل محافظة Sub نقل_البيانات_بين_الملفات() Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowSource As Long, lastColSource As Long Dim lastRowDest As Long Dim i As Long, j As Long Dim itemCode As String, monthDate As String Dim sourceData As Variant, wsName As String Dim filePath As String Dim wsFoundSource As Boolean Dim sheetNames As Variant Dim sheetName As Variant ' متغير لحلقة التكرار على الأوراق ' تعيين الكائنات Set wbDest = ThisWorkbook ' تحديد مسار الملف المصدر filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx" ' فتح الملف المصدر مع معالجة الأخطاء On Error Resume Next Set wbSource = Workbooks("رصيد التوكيلات1.xlsx") On Error GoTo 0 If wbSource Is Nothing Then On Error Resume Next Set wbSource = Workbooks.Open(filePath) On Error GoTo 0 If wbSource Is Nothing Then MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical Exit Sub End If End If ' تحديد النطاق في ملف المصدر With wbSource.Sheets(1) ' يمكنك تغيير رقم 1 إلى اسم ورقة العمل إذا كانت مختلفة sourceData = .Range("F4:S71").Value ' تحديد النطاق F4:S71 End With ' مصفوفة أسماء الأوراق المطلوبة (عدّل هذه الأسماء) sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") ' تكرار على أسماء الأوراق For Each sheetName In sheetNames ' البحث عن الورقة المطلوبة في ملف الوجهة On Error Resume Next Set wsDest = wbDest.Sheets(sheetName) On Error GoTo 0 ' إذا تم العثور على الورقة في ملف الوجهة If Not wsDest Is Nothing Then ' إدخال البيانات في ورقة العمل الوجهة If Not IsEmpty(sourceData) Then ' تحديد الصف الأخير في ورقة العمل الوجهة lastRowDest = wsDest.Cells(wsDest.Rows.Count, 2).End(xlUp).Row + 1 ' نقل البيانات من المصفوفة إلى ورقة العمل For i = 1 To UBound(sourceData, 1) ' الصفوف في المصفوفة For j = 1 To UBound(sourceData, 2) ' الأعمدة في المصفوفة wsDest.Cells(lastRowDest + i - 1, j + 5).Value = sourceData(i, j) ' بدءًا من العمود G (العمود 7) Next j Next i End If End If Next sheetName ' إغلاق الملف المصدر (اختياري) wbSource.Close SaveChanges:=False End Sub