hegazee

جرب هذا الكود Sub Hyperlink_cut() Dim selectedFile As String Dim result As Variant ' فتح مربع حوار لاختيار الملف With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel المراد قطع الرابط معه" .Filters.Clear .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm" .AllowMultiSelect = False If .Show = -1 Then selectedFile = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف.", vbExclamation Exit Sub End If End With ' محاولة قطع الرابط On Error Resume Next ActiveWorkbook.BreakLink Name:=selectedFile, Type:=xlExcelLinks If Err.Number <> 0 Then MsgBox "تعذر قطع الرابط. تأكد أن الملف مرتبط فعلاً.", vbCritical Exit Sub End If On Error GoTo 0 ' تحديد خلية H9 Range("H9").Select ' تحديد الشكل "Rectangle 4" On Error Resume Next ActiveSheet.Shapes.Range(Array("Rectangle 4")).Select On Error GoTo 0 ' الانتقال إلى المرجع "Macro1" On Error Resume Next Application.Goto Reference:="Macro1" On Error GoTo 0 End Sub

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

و عليكم السلام ورحمة الله و بركاته جرب الملف المرفق (2)استخراج_فواتير_بدون_تكرار.xlsx

و عليكم السلام ورحمة الله وبركاته حسب فهمي للملف أن الكود يحول البيانات إلى أرقام و تواريخ حسب العمود. و لا أعرف لماذا تمت تسمية زر تشغيل الكود بلصق الاختيارت. قمت بتعديل أشاء بسيطة بالكود للتأكد من تنسيق الخلايا حسب المطلوب بس تأكد من التواريخ المكتوبة يوم و شهر تجرة(2).xlsb

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

حاول ترفع أي ملف فيه مشكله هنا. و إذا كان حجمه كبير ارفعه على جوجل درايف

تفضل الملف . حطيت بعض المعلومات العشوائية لاختبار المعادلة شهر 12022(2).xlsx

من الأفضل رفع ملف ليتم العمل عليه

تفضل Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub

بعد إذن أساتذتي حل بالمعادلات بشكل مبسط BB (3).xlsx

جرب الكود التالي: Sub CheckDifferences() Dim ws As Worksheet Dim lastRow As Long Dim r As Long Dim values(1 To 7) As Variant Dim result As String Dim i As Integer, j As Integer Dim count As Integer Dim isFirstDiff As Boolean Set ws = ThisWorkbook.Sheets("Sheet1") ' ✏️ غيّر اسم الشيت إذا لزم lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' تنظيف العمود O قبل الكتابة ws.Range("O3:O" & lastRow).ClearContents ws.Range("O3:O" & lastRow).Interior.ColorIndex = xlNone ws.Range("O3:O" & lastRow).Font.ColorIndex = xlAutomatic For r = 3 To lastRow ' قراءة القيم من C إلى I For i = 1 To 7 values(i) = ws.Cells(r, i + 2).Value Next i result = "" isFirstDiff = True For i = 1 To 7 count = 0 For j = 1 To 7 If values(j) = values(i) Then count = count + 1 Next j If count = 1 Then If Not isFirstDiff Then result = result & " و " End If result = result & "العمود " & Chr(64 + i + 2) & " مختلف" isFirstDiff = False End If Next i With ws.Cells(r, 15) ' العمود O .Value = Trim(result) If result <> "" Then .Interior.Color = vbYellow ' تعبئة باللون الأصفر .Font.Color = vbRed ' الخط باللون الأحمر End If End With Next r End Sub

و عليكم السلام ورحمة الله وبركاته أسهل شيء استخدام التنسيق الشرطي (2)2025 اسم التوكيل.xlsm

تفضل أخي ملفين الملف الأول: يقوم بطباعة أوراق العمل حسب ما تكتبه من نطاقات في كل رسالة تظهر الملف الثاني : ما عليك إلا كتابة نطاق طباعة كل صفحة في الخلية A1 و البرنامج يقوم بطباعتها ملاحظات: · إذا اختار المستخدم الطباعة، تطبع جميع الأوراق في دفعة واحدة. · إذا اختار حفظ PDF، تنسخ هذه الأوراق إلى مصنف مؤقت ثم يصدر إلى PDF. *عند التصدير بصيغة PDF اختر مجلد لحفظ ملف الطباعة فيه *أهم شيء تنسيق الصفحات و الهوامش حيث لاحظت أن بعض الصفحات تتم طباعتها على ورقتين لعدم ضبط المسافات و الحدود أيضا عند تغيير أسماء أوراق العمل في الملف الأول لابد أن تغيرها في الكود. طباعة اكثر من صفحة.xlsb طباعة اكثر من صفحة من خلال خلية.xlsb

وعليكم السلام ورحمة الله و بركاته Sub PrintOrExportPDF_CustomRanges() Dim ws As Worksheet Dim rngAddress As String Dim sheetNames As Variant Dim printableSheetNames() As String Dim i As Integer, count As Integer Dim printChoice As VbMsgBoxResult Dim savePath As String Dim fileName As String ' أسماء الأوراق (عدّل حسب أوراقك) sheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4") count = 0 ' سؤال المستخدم: طباعة أم PDF؟ printChoice = MsgBox("هل ترغب في طباعة الأوراق؟" & vbCrLf & "اضغط 'نعم' للطباعة، 'لا' لحفظ كـ PDF.", vbYesNoCancel + vbQuestion, "اختيار نوع الإخراج") If printChoice = vbCancel Then MsgBox "تم إلغاء العملية.", vbExclamation Exit Sub End If Application.ScreenUpdating = False ' تحديد النطاقات For i = LBound(sheetNames) To UBound(sheetNames) Set ws = ThisWorkbook.Sheets(sheetNames(i)) rngAddress = InputBox("أدخل النطاق المطلوب طباعته من الورقة: " & sheetNames(i), "تحديد نطاق الطباعة") If rngAddress <> "" Then On Error Resume Next ws.PageSetup.PrintArea = rngAddress If Err.Number = 0 Then count = count + 1 ReDim Preserve printableSheetNames(1 To count) printableSheetNames(count) = ws.Name End If On Error GoTo 0 Else MsgBox "تم تخطي الورقة: " & sheetNames(i), vbInformation End If Next i ' تنفيذ العملية حسب الاختيار If count > 0 Then If printChoice = vbYes Then ' ? طباعة مباشرة Sheets(printableSheetNames).PrintOut MsgBox "تمت طباعة الأوراق المحددة بنجاح.", vbInformation ElseIf printChoice = vbNo Then ' ? تصدير كـ PDF (بمصنف مؤقت) With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then MsgBox "لم يتم اختيار مجلد.", vbExclamation Exit Sub End If savePath = .SelectedItems(1) End With fileName = InputBox("أدخل اسم ملف PDF بدون .pdf", "اسم الملف") If fileName = "" Then MsgBox "لم يتم إدخال اسم الملف.", vbExclamation Exit Sub End If ' إنشاء مصنف مؤقت Dim tempBook As Workbook Set tempBook = Workbooks.Add ' نسخ الأوراق للمصنف المؤقت For i = 1 To count ThisWorkbook.Sheets(printableSheetNames(i)).Copy After:=tempBook.Sheets(tempBook.Sheets.count) Next i ' حذف الورقة الافتراضية الفارغة Application.DisplayAlerts = False Do While tempBook.Sheets.count > count tempBook.Sheets(1).Delete Loop Application.DisplayAlerts = True ' حفظ كـ PDF tempBook.ExportAsFixedFormat _ Type:=xlTypePDF, _ fileName:=savePath & "\" & fileName & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True ' إغلاق المصنف المؤقت بدون حفظ tempBook.Close SaveChanges:=False MsgBox "تم حفظ ملف PDF بنجاح.", vbInformation End If Else MsgBox "لم يتم تحديد أي ورقة للطباعة أو التصدير.", vbExclamation End If Application.ScreenUpdating = True End Sub

نعم، برنامج الأوفيس ومن ضمنه Excel متوفر بنسختين: إصدار 32bit و إصدار 64bit

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

و عليكم السلام الكود التالي يحقق المطلوب فقط تأكد من أن الملفين في نفس المسار Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String WSname = "إدخال بيانات أساسية" ' تأكد من أن الاسم مطابق تمامًا On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ' تحديد مسار الملف FilePath = ThisWorkbook.Path & "\Book2.xlsb" ' تأكد من امتداد الملف ' التحقق من وجود الملف If Dir(FilePath) = "" Then MsgBox "ملف Book2 غير موجود في المسار: " & vbCrLf & FilePath, vbExclamation Exit Sub End If ' فتح الملف بكلمة المرور Set Wb1 = Workbooks.Open(FilePath, Password:="123") ' تأكد من كلمة المرور Set Wb2 = ThisWorkbook ' التحقق من وجود ورقة العمل Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "ورقة العمل '" & WSname & "' غير موجودة في أحد الملفين", vbCritical Wb1.Close False Exit Sub End If ' نسخ البيانات Set OnRng = WSdata.UsedRange If OnRng.Cells.CountLarge = 1 And IsEmpty(OnRng.Value) Then MsgBox "لا توجد بيانات في الورقة المصدر", vbExclamation Wb1.Close False Exit Sub End If WSdest.Cells.UnMerge WSdest.Cells.ClearContents OnRng.Copy With WSdest.Range("A1") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Wb1.Close False MsgBox "تم نسخ البيانات بنجاح", vbInformation ExitHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume ExitHandler End Sub

و عليكم السلام ورحمة الله و بركاته ثبت إصدار 64 بت من Office على اللاب توب الجديد لأنه إذا كان Office على اللاب توب 32 بت، فقد يكون هذا هو سبب المشكلة، لأن الماكرو التي تم إنشاؤها على 64 بت لا تعمل بشكل صحيح. افتح Excel على اللاب توب، واذهب إلى: ملف > خيارات > مركز التوثيق > (Trust Center) > إعدادات مركز التوثيق > إعدادات الماكرو. اختر تمكين جميع وحدات الماكرو أو تعطيل وحدات الماكرو مع الإشعار للسماح بتفعيل الماكرو يدويًا عند فتح الملف.

آمين يا رب العالمين. و إياكم أجمعين

و أنتم بخير . جرب الكود التالي في الملف الأول Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "ملف 1" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If ' تحديد النطاق من F9 إلى S609 Set OnRng = WSdata.Range("F9:S609") WSdest.Cells.UnMerge WSdest.Range("F9:S609").ClearContents ' مسح النطاق المحدد فقط OnRng.Copy With WSdest.Range("F9") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("F9"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

و عليكم السلام ورحمة الله و بركاته جرب الكود التالي في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim inputValue As String Dim parts() As String Dim secondPart As String Dim hasLetter As Boolean Dim letterPos As Integer Dim i As Integer Dim errorMsg As String ' التحقق من أن التغيير حدث في العمود E (العمود الخامس) If Not Intersect(Target, Me.Columns(5)) Is Nothing Then Application.EnableEvents = False ' تعطيل الأحداث مؤقتًا لتجنب التكرار For Each cell In Intersect(Target, Me.Columns(5)) If Not IsEmpty(cell) Then inputValue = Trim(cell.Value) errorMsg = "" ' التحقق من وجود الشرطة المائلة (/) If InStr(inputValue, "/") > 0 Then errorMsg = errorMsg & "خطأ: يجب استخدام الشرطة العادية (-) بدلاً من الشرطة المائلة (/)." & vbCrLf End If ' التحقق من التنسيق العام If InStr(inputValue, "-") > 0 Then parts = Split(inputValue, "-") If UBound(parts) = 1 Then secondPart = parts(1) ' التحقق من وجود صفر في بداية الجزء الثاني If Left(secondPart, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الشرطة (-)." & vbCrLf End If ' التحقق من وجود حرف إنجليزي في الجزء الثاني hasLetter = False letterPos = 0 For i = 1 To Len(secondPart) If secondPart Like "*[a-zA-Z]*" Then hasLetter = True Exit For End If Next i ' التحقق من وجود صفر بعد الحرف الإنجليزي (إن وجد) If hasLetter Then letterPos = InStr(secondPart, Left(secondPart, 1)) If letterPos > 0 And Mid(secondPart, letterPos + 1, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الحرف الإنجليزي." & vbCrLf End If End If Else errorMsg = errorMsg & "خطأ: تنسيق رقم الحالة غير صحيح. يجب أن يكون على شكل (أرقام-أرقام) أو (أرقام-حرف أرقام)." & vbCrLf End If Else errorMsg = errorMsg & "خطأ: يجب أن يحتوي رقم الحالة على شرطة عادية (-)." & vbCrLf End If ' إذا كان هناك خطأ، عرض رسالة تحذير وإلغاء الإدخال If errorMsg <> "" Then MsgBox errorMsg, vbCritical, "خطأ في إدخال رقم الحالة" cell.Value = "" End If End If Next cell Application.EnableEvents = True ' إعادة تفعيل الأحداث End If End Sub Book1.xlsm

الملف المرسل في مشاركة سابقة ممتاز و يعمل بكفاءة و يوزع عدد 2 ملاحظين في كل لجنة برجاء تجربتة و كتابة ملاحظاتك. قمت بتعديل عدد اللجان و الملاحظين ليتوافق مع اللجان عندك توزيع الملاحظين .xlsm

ما المقصود بعدد الملاحظين حيث الأرقام في العمود متسلسلة؟ هل عدد اللجان المقصود منه رقم اللجنة أم إجمالي اللجان التي سيتم توزيع الملاحظين عليه. كلما كانت المعطيات واضحة كلما كانت النتائج أفض.

عندما يكون العدد كبير يمكن التحكم في الشروط و لكن الواقع غير ذلك فيكون أهم شرط هو التساوي قدر الأمكان أما دخول نفس اللجان فيتم التحكم فيها يدويا . جرب الملف المرفق بعد تعديل الكود كود (1).xlsm