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

السلام عليكم 🙂 اخواني ، الجميع يساعد في المنتدى بوقته وبدون مقابل ، وعندنا مثل يقول: حبة الزبيب ما تشبّع ، ولكنها تحلّي الفم 🙂 فرجاء خلونا نشجع الاعضاء في العطاء 🙂 لما تحصل على رد له قيمة ، فتشجيعا للعضو الذي يساعدك ، اخبر العضو بأنك مُعجب برده ، هكذا : . . ولما تحصل على اجابة لسؤال موضوعك ، فرجاء اختيار افضل اجابة ، هكذا (حتى مستقبلا يسهل معرفة الاجابة الصحيحة) : . شكرا 🙂 جعفر ومع الاعتذار لأخي احمد لإستخدام اسمه في المثال 🙂

السلام عليكم 🙂 الجوازات والبطاقات الشخصية والهويات الحكومية ، في اسفلها كود يسمى MRZ وفيه معلومات من الوثيقة ، الجواز ، وفي اسفله سطرين من كود MRZ : . والهوية ، وفي اسفلها 3 اسطر من كود MRZ : . وهناك عدة اجهزة (هي في الواقع سكانرات) التي يمكنها قراءة هذه الوثائق ، وتستعمل نظام OCR وتحول الصورة الى نص ، ومن ضمن هذه الاجهزة ، جهاز 3M CR100 https://www.gemalto.com/govt/document-readers/cr100 والظاهر ان هذا الجهاز معتمد من قِبل البوابة الالكترونية الموحدة لحجاج الخارج . . تنزيل وتنصيب برنامج التشغيل : http://www.3m.com/ssdcp/3M Swipe Readers/SDK/3M Swipe Reader SDK 1.2.1.2 Setup.exe خلونا نستعمل هذا الجهاز عن طريق الاكسس 🙂 بعد تنصيب برنامج تشغيل الجهاز ، يقوم برنامج الاكسس بتشغيل برنامج الجهاز في الكمبيوتر (فإذا ما عملت تنصيب للبرنامج ، اوقف عمل السطر : ) Private Sub Form_Load() On Error GoTo err_Form_Load 'turn ON the scanner xml program ' Call Restart_XML '<<< اوقفوا عمل هذا السطر . النموذج يكون جاهز على الحقل Line_0 ، والذي يبدا بأخذ نتيجة OCR ، . . وتكون النتيجة بهذه الطريقة (انا وضعت الارقام امام الاسطر) : 0'START 1'OCR Line 1: IDOMN1900000<<3<<<<<<<<<<<<<<< 2'OCR Line 2: 7008529M2018227OMN<<<<<<<<<<<6 3'OCR Line 3: ALI<MOHAMMED<HUSSAIN<<AL<MOOSA 4'MSR Track 1: 5'MSR Track 2: 6'MSR Track 3: 7'End . لعمل البرنامج ، اضطررت لعمل الاكواد بنفسي ، لأن SDK الجهاز كانت للغات اخرى غير VBA ، وهذه الوحدة النمطية التي تقوم بتفكيك الكود اعلاه ، سواء لجواز او بطاقة او فيزا : Public Function Parse_MRZ(frmN As String) On Error GoTo err_Parse_MRZ ' '08-06-2018 'by jjafferr ' Dim L1 As String Dim L2 As String Dim L3 As String Dim gDocType As String Dim Pass_Type As String Dim gLastName As String Dim gFirstName As String L1 = Replace(Forms(frmN)!Line_1, "OCR Line 1: ", "") L2 = Replace(Forms(frmN)!Line_2, "OCR Line 2: ", "") L3 = Replace(Forms(frmN)!Line_3, "OCR Line 3: ", "") gDocType = Mid(L1, 1, 1) Select Case gDocType Case "P", "V" 'passport , Visa Forms(frmN)!gDocType = gDocType 'LINE 1 Pass_Type = Mid(L1, 2, 1) 'Either < or Passport type Forms(frmN)!gIssuing = Mid(L1, 3, 3) gLastName = Mid(L1, 6, InStr(L1, "<<") - 6) gLastName = Replace(gLastName, "<", " ") Forms(frmN)!gLastName = Trim(gLastName) gFirstName = Mid(L1, InStr(L1, "<<") + 2, InStr(InStr(L1, "<<") + 1, L1, "<<") - InStr(L1, "<<") - 2) gFirstName = Replace(gFirstName, "<", " ") Forms(frmN)!gFirstName = Trim(gFirstName) Forms(frmN)!gDocNumber = Mid(L2, 1, 9) 'LINE 2 Forms(frmN)!gCountry = Mid(L2, 11, 3) Forms(frmN)!gDOB = DateSerial(Mid(L2, 14, 2), Mid(L2, 16, 2), Mid(L2, 18, 2)) Forms(frmN)!gGender = Mid(L2, 21, 1) Forms(frmN)!gDocExpiry = DateSerial(Mid(L2, 22, 2), Mid(L2, 24, 2), Mid(L2, 26, 2)) Forms(frmN)!gAddInfo = Mid(L2, 29, InStr(L2, "<<") - 29) Case "I", "A", "C" 'ID Forms(frmN)!gDocType = Mid(L1, 1, 2) Pass_Type = Mid(L1, 2, 1) 'Either < or completing the first letter Forms(frmN)!gIssuing = Mid(L1, 3, 3) Forms(frmN)!gDocNumber = Mid(L1, 6, InStr(L1, "<<") - 6) Forms(frmN)!gDOB = DateSerial(Mid(L2, 1, 2), Mid(L2, 3, 2), Mid(L2, 5, 2)) 'LINE 2 Forms(frmN)!gGender = Mid(L2, 8, 1) Forms(frmN)!gDocExpiry = DateSerial(Mid(L2, 9, 2), Mid(L2, 11, 2), Mid(L2, 13, 2)) Forms(frmN)!gCountry = Mid(L2, 16, 3) gFirstName = Mid(L3, 1, InStr(L3, "<<") - 1) 'LINE 3 gFirstName = Replace(gFirstName, "<", " ") Forms(frmN)!gFirstName = Trim(gFirstName) gLastName = Mid(L3, InStr(L3, "<<") + 2) gLastName = Replace(gLastName, "<", " ") Forms(frmN)!gLastName = Trim(gLastName) End Select Exit_Parse_MRZ: Exit Function err_Parse_MRZ: If Err.Number = 9 Then 'susbcription out of order, ignore Resume Next ElseIf Err.Number = 13 Then 'Type mismatch, ignore Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_Parse_MRZ End If End Function برنامجي الذي في الخدمة ، يقرأ بيانات الجوازات والهويات في اقل من 3 ثواني ، بالأضافة الى قراءة باركود بعض الهويات الاخرى ، وادخال يدوي لأنواع اخرى من الهويات ، لهذا السبب كان يتطلب مني استعمال هذه الاحداث🙂 Public Sub Line_0_BeforeUpdate(Cancel As Integer) Private Sub Line_0_KeyDown(KeyCode As Integer, Shift As Integer) Private Sub Line_0_AfterUpdate() Private Sub Line_7_AfterUpdate() . احد اهم الامور التي اخذت مني وقت طويل لمعرفتها هي ، يجب ان تكون لغة الكيبورد بالانجليزي ، وقت قراءة البطاقة ، وإلا فالنتائج تعطيك خطأ ، لهذا السبب فالبرنامج تلقائيا يحول اللغة الى انجليزي ، لما التركيز يكون في حقل Line_0 🙂 الجدول و الكود قد يكون فيه بقايا من برنامجي ، ولكن لن يضروكم ان شاء الله 🙂 جعفر CR100 card reader.zip

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

ممكن ذلك من خلال هذا التعديل على الكود Option Explicit Sub Find_Dupl_Rows_new() Dim I%, Ro, m% Dim REP As Range, My_Rg As Range Dim COl As Collection Dim Arr, n Set COl = New Collection Set My_Rg = Range("A1").CurrentRegion Ro = My_Rg.Rows.Count Set My_Rg = My_Rg.Offset(1).Resize(Ro - 1) My_Rg.Interior.ColorIndex = xlNone Range("E2").Resize(Ro - 1).ClearContents Range("G2:K2").Resize(Ro - 1).Clear For I = 2 To Ro Arr = Application.Transpose(Application.Transpose _ ((Cells(I, 2).Resize(, 3)))) Arr = Join(Arr, "*") On Error Resume Next COl.Add I, Arr If Err.Number <> 0 Then m = m + 1 Cells(I, 5) = "Duplicate" Cells(I, 5).Interior.ColorIndex = 40 If REP Is Nothing Then Set REP = Cells(I, 2).Resize(, 3) Else Set REP = Union(REP, Cells(I, 2).Resize(, 3)) End If 'REP End If 'Err Next I On Error GoTo 0 If Not REP Is Nothing Then REP.Interior.ColorIndex = 40 MsgBox "You have :" & m & " duplicate Rows" n = REP.Areas.Count m = 1 For I = 1 To n Range("G1").Offset(m).Resize(REP.Areas(I). _ Rows.Count, 3).Value = REP.Areas(I).Value Range("j1").Offset(m) = REP.Areas(I).Address Range("K1").Offset(m) = REP.Areas(I).Rows.Count m = m + REP.Areas(I).Rows.Count Next '================================= With Cells(2, "g").Resize(m - 1, 5) .Borders.LineStyle = 1: .Font.Size = 16 .Font.Bold = True: .Interior.ColorIndex = 28 .InsertIndent 1 End With '========================= Else MsgBox "Not duplicate Rows " End If Set COl = Nothing: Set REP = Nothing End Sub

تفضل تم وضع المعادلة في العمود E وتتم الفلترة من خلال هذا العمود =IF(AND(ISBLANK(B2);ISBLANK(C2));"إخفاء الصف";"") Filtering.xlsx

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

ممكن جمع الارقام في مربعات النص باستخدام دالة val Val([ملف_انجاز])+Val([امتحان]) جرب المرفق جمع الارقام من مربع نص تنسيقه نص1.accdb

تفضل -يمكنك استخدام معادلة المصفوفة .... لا تنسى الضغط على Ctrl+Shift+Enter =MIN(IF($B$5:$B$21>=TODAY(),$B$5:$B$21)) اظهار التاريخ القادم2.xlsx

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

تفضل 1- ضع المجلد في القسم c 2- الخلية a1 تحتوي على مسار الملفات وهي ثابته لاتغيرها 3- الخلايا من " a2:a400 " تحوي معادلة جلب اسماء الملفات وامتدادها في المجلد المسمى "الملف موجود ام غير موجود" بالاعتماد على دالة تم وضعها في محرر الاكواد 4- اكتب اسم الملف في الخلية b1 سيتم اجراء فلترة للعمود a اذا لم ييظهر اسم الملف بعد الفلترة يعني اما مفقود من المجلد... او لم تكتب اسمه بالشكل الصحيح المطابق لاسم الملف 5- اذا رغبت بتغير اسم المجلد او نقله لمكان اخر يجب تحديث المسار الجديد ونسخه في الخلية a1 الملف موجود أم غير موجود.rar

وعليكم السلام اتفضل ان شاء الله يكون ما طلبت حتى وانت فاتح النموذجين سيتم التحديث بمجرد انتقالك للسجل التالى وليس للحقل التالى تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق Aa_New Microsoft Access Database.rar

ربما كان هذا المطلوب Repeet_by_choise.xlsx

بارك الله فيك ووفقك الله دائما الى مساعدة الأخرين

وعليكم السلام 🙂 في حقل رقم في الجدول ، لا يمكنك ان تُدخل حروف ، ولكن يمكنك ان تُدخل اي رقم تريد 🙂 فخلينا نقول ، ان الغائب تعطيه علامة 200 : وفي الاستعلام ، نعمل معادلة: اذا كان الرقم = 200 ، فأعطنا الحرف غ 🙂 جعفر جمع الارقام من مربع نص تنسيقه نص1.zip

أحسنت استاذ سليم بارك الله فيك وزادك الله من فضله

بارك الله فيك استاذ أحمد

جرب هذه المعادلة =EDATE($A$1,$A$2)

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

وعليكم السلام -طبعا اخى الكريم فى ملف اكسيل

بارك الله فيك أخى الكريم ونوت المنتدى

أحسنت استاذ سليم دائما مبدع -بارك الله فيك وزادك الله من فضله ووسع الله فى رزقك

السلام عليكم تفضل اخي الكريم طلبك 1- الطريقة الاولى يتغير لون النموذج حسب الايام من السبت الى الجمعة عن الفتح وكذلك عملت لك ازرار يتغير اللون عند الانتقال لليوم التالي 2- الطريقة الثانية دالة تستخرج اليوم من التاريخ بدوت استعلام من خلال النموذج فقط وكل يوم يقتح النموذج بلون من السيبت لغاية الخميس تحياتي mm.rar فتح النموذج كل يوم بلون معين.rar

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

الأستاذ gelani البرنامج يعمل تمام انظر للصورة المرفقة .... لا تضيف البيانات أثناء فتح الجدول tbl

هل تريد ترحيل هذه الأعمدة المتفرقة إلى ورقة all فى أعمدة متجاورة أم بنفس أسماء الأعمدة؟؟؟ بمعنى العمود مثلا : C ينقل إلى ورقة الهدف فى العمود C وهكذا

جزاك الله خيرا نتعلم منكم

🙂 جعفر

السلام عليكم فقط قمت باضافة حقل ID تفضل اخي اتمنى يكون المطلوب ESAL-1.rar

وعليكم السلام 🙂 هكذا تضع اكثر من شرط ، وببساطة 🙂 جعفر

لو سمحت اخي ممكن ترفع صورة عن المشكلة او الملف الذي تعمل عليه لانه يمكن ان تكون هناك معادلات تعمل المشكلة دي عموما الكود يعمل عندي بحيث لما تعمل ضوبل كليك بالماوس على اي اسم في شيت 1 ينتقل الى الشيت2 ويظهر الاسم ورقم الهاتف في استمارة واحدة

مثل هذا الجهاز AT9000 ، ويعمل بنفس طريقة الجهاز CR100 بأته يأخذ كود MRZ ويفككه (وسيكون مشروعي التالي ان شاء الله 🙂 ) ، وبالاضافة يأخذ: صورة ملونة لصفحة الجواز ، صورة ابيض واسود لصفحة الجواز (لكشف التزوير) ، صورة من صورة صاحب الجواز الشخصية ، . . نعم يمكن التحكم في هذا ، بطريقتين: عن طريق ملف XML ، او بتفكيك السطر على اساس علامات "<" (لاحظ الوحدة النمطية في مشاركتي الأولى) ، او الاثنين معا 🙂 جعفر

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

اولاً من باب الحفاظ على الملكية الفكرية يجب عليك ذكر من وضع لك المعادلات (UDF Function) ثانياً انت قمت بوضع ماكروات تمنع الحسابات (Xl Calculation=xlManual) لذلك لا يقوم الماكرو بتنفيذ المعادلات تم توقيف هذه الماكروات ثالثا ما ضرورة رفع ملف من اكثر من 1500 صف في حين 20 صف تكفي للمعاينة رابعاً تم معالجة الامر الملف مرفق work Sheet_salim.xlsm

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

أسعدك الله وجزاك خيرا .. سامحني أستاذي الفاضل لو كنت أثقلت عليك ..

اخي العزيز المشكله في الاستعلام وانا شرحتها لك سابقا وهي (ان الحقول A8 , A9 هي فارغة تماما ) احذف المعيار ISNULL منها لانها فارغة اصلا لو وضعتها سوف تظهر لك كل السجلات لان المعيار ينطبق عليها تحياتي FMARK.rar

وعليكم السلام ورحمة الله وبركاته =DATE(YEAR(A1);MONTH(A1)+B2;DAY(A1)) =DATE(YEAR(A1);MONTH(A1)+3;DAY(A1)) معادلتين : إما كتابة الرقم المضاف أو تعيين خلية لإضافة الرقم للشهر المعادلة تؤدي الغرض ويمكن للأساتذة أضافة نستفيد منها Month+3.xlsx

اتفضل المعادلة التالية CONCATENATE ضعها فى الخلية H9 مع السحب لأسفل لنسخها فى باقى خلايا العمود =CONCATENATE(D9;E9;F9;G9) ويمكن أيضا استخدام هذه الطريقة باستخدام & =D9&E9&F9&G9

السلام عليكم 1- الملف الاول فيه تنبيه انك ادخلت رقم ايصال (ويعطيك رقمه برسالة) سابقا ويرفض التسجيل 2- الملف الثاني فيه تنبيه انك ادخلت رقم ايصال (ويعطيك رقمه برسالة) سابقا ويسمح التسجيل اتمنى يكون طلبك تحياتي ESAL-1.rar ESAL-2.rar

وعليكم السلام-حاول استخدام هذا الكود Sub ProtectAll() Dim wBk As Workbook Dim sFileSpec As String Dim sPathSpec As String Dim sFoundFile As String sPathSpec = "C:\MyPath\" sFileSpec = "*.xls" sFoundFile = Dir(sPathSpec & sFileSpec) Do While sFoundFile <> "" Set wBk = Workbooks.Open(sPathSpec & sFoundFile) With wBk Application.DisplayAlerts = False wBk.SaveAs FileName:=.FullName, _ Password:="swordfish" Application.DisplayAlerts = True End With Set wBk = Nothing Workbooks(sFoundFile).Close False sFoundFile = Dir Loop End Sub أو جرب هذا Add password to all Excel workbook in folder او تلك Lock a Folder – In Windows – Excel Folder Lock Code أو هذا How to protect all workbooks in a folder at once in Excel?

وعليكم السلام 🙂 بعض الاوقات ، وهذا حصل معي ، يعطب الكومبوبوكس !! فلا تحاول وتعمل اي شيء ، سوى حذفه وعمله من جديد (لا تنسخ الكائن/الكومبوبوكس القديم ، نعم تقدر تنسخ الكود) 🙂 جعفر

الآن سؤالك كامل وواضح 🙂 لما تُدخل البيانات ، سؤاء في الجدول او الاستعلام او النموذج ، ترى ان طرف السجل عليه هذه العلامة : . هذه العلامة معناها انك في وضع إدخال المعلومة / تعديلها / تحديثها ، ولكنك لم تحفظها بعد ، فلما تخرج من السجل (خروجك من الحقل الى حقل آخر معناه انك لازلت على نفس السجل) ، سواء الى السجل السابق او التالي او اي سجل او حتى خروجك من الجدول / الاستعلام / النموذج (لأن الاكسس تلقائيا يحفظ السجل في هذه الحالات) ، هنا فقط الاكسس يحفظ بيانات السجل ، وعليه تختفى هذه العلامة 🙂 بعض الاوقات في النموذج نكون نُدخل البيانات ، والاكسس لا يكون قد حفظ السجل ، لهذا السبب ، لا تظهر هذه المعلومة الجديدة في التقرير (لانها اصلا غير محفوظة في الجدول) 🙂 والطريقة هي ان نُجبر البرنامج على حفظ السجل قبل طباعة التقرير ، وهناك عدة طرق لذلك ، ومنها : 1. النقر على زر Refresh All (مثل ما عملت انت) والذي يضطر البرنامج الى دفع ثمن باهض ، بتحديثه سجلات جميع الجداول (وهذا يأخذ وقت اذا كان عدد الجداول كثير او في شبكة) التي في البرنامج (واذا كنت تشتغل في بيئة اكثر من مستخدم وهناك من يدخل البيانات ، فحتى بياناتهم يتم تحديثها غصبا عنهم) ، 2. استخدام الكود ، قبل سطر طباعة التقرير (هذا الكود الاسرع) : يحفظ البيانات فقط اذا تم عمل تغيير عليها if me.dirty then me.dirty=false او سيتم حفظ البيانات بغض النظر اذا تم تعديل عليها او لا docmd.runcommand accmdsaverecord 3. استخدام الكود ، قبل طباعة التقرير (وهذا ابطئ ، لأنه يضطر الى تحديث بيانات الجدول ، ثم جلبها الى النموذج) : me.Refresh او me.Requery . جعفر

تلوين اسماء الشيتات بضغطة واحدة لاى عدد من الشيتات الفيديو

انا لا ارى اى مشكلة فى الفلترة فهى تعمل عندى تمام

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

اهلا بك اخ كريم فى المنتدى يمكنك البحث عن هذا البرنامج وتحميله ثم قم بتسطيبه : Passware Passware Kit Forensic.v13.5.8557.x32-BRD

اهلا بك اخ كريم فى المنتدى تفضل لك ما طلبت وجدت هذا الملف عندى دالة التفقيط باللغة التركية.xlsm او جرب هذا turk.xlsm

Option Explicit Sub TARHIL() Dim Sh As String Dim i As Integer Dim AA As Integer '====================================================== Application.ScreenUpdating = False Sheets("جنح").Range("A2:O1000").ClearContents Sheets("مدنى").Range("A2:O1000").ClearContents 'يمكنك فى هذا الجزء اضافة اى شيت اخر جديد على نفس هذه الطريقة الموجودة '====================================================== For i = 2 To Cells(10000, "A").End(xlUp).Row Sh = Cells(i, "D").Value AA = Sheets(Sh).Cells(10000, 1).End(xlUp).Row + 1 If AA < 2 Then AA = 2 On Error Resume Next Range(Cells(i, "A"), Cells(i, "O")).Copy Sheets(Sh).Range("A" & AA).PasteSpecial xlPasteValues Application.CutCopyMode = False Sheets(Sh).Cells(AA, "A").Value = Sheets(Sh).Cells(AA, "A").Row - 1 Next i Application.ScreenUpdating = True MsgBox "تم الترحيل بنجاح" End Sub

تفضل اخى الكريم أجندة محامى (Autosaved).xlsm