احمدزمان

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

عملنا كوود جديد يقوم بكل الخطوات كما يلي ياخذ نوع السند و رقم السند اذا كان لايوجد رقم للسند او لا يوجد نوع للسند يعني فراغ - يعطيك رسالة اكمال البيانات يذهب الى ورقة 2 يشيك على كل البيانات في ورقة 2 من الصف 2 الى نهاية الورقة اذا وجد اي تطابق مع رقم السند و نوع السند الإثنان معا - يعطيك رسالة انه مكرر ---- اذا لم يجد السند مكرر يقوم بترحيل كامل الصف للبيانات ويمسح لك بيانات الصف الذي تم ترحيله بعد انتهاء عمل الكود سوف يبقى لديك في ورقة 1 البيانات المكررة و البيانات الناقصة اما البيانات التي اكتملت و غير مكررة سوف تجدها قد نقلت الى ورقة 2 و غير موجودة في ورقة 1 Sub MUKArar() Dim FS As Worksheet, TS As Worksheet Dim FR, TR, ER1, ER2, Q1, Q2 Set FS = Sheets("Sheet1") Set TS = Sheets("Sheet2") ER1 = FS.UsedRange.Rows.Count ER2 = TS.UsedRange.Rows.Count TR2 = Application.CountA(TS.Range("A1:A5555")) FS.Range("I2:I" & ER1).ClearContents For FR = 2 To ER1 Q1 = FS.Cells(FR, 3).Text Q2 = FS.Cells(FR, 4).Value If Q1 = "" Or Q2 = "" Then FS.Cells(FR, 9) = "اكمل ادخال البيانات" MsgBox FS.Cells(FR, 9).Text GoTo 7 End If For TR = 2 To ER2 If TS.Cells(TR, 3) = Q1 And TS.Cells(TR, 4) = Q2 Then FS.Cells(FR, 9) = "مكرر - " & TR MsgBox Q1 & " - " & Q2, , "مكرر" GoTo 7 End If Next TR 6 TR2 = TR2 + 1 If TS.Cells(TR2, 1) <> "" Then GoTo 6 If FS.Cells(FR, 9) = "" Then For FC = 1 To 9 TS.Cells(TR2, FC) = FS.Cells(FR, FC) FS.Cells(FR, FC).ClearContents Next FC End If 7 Next FR End Sub جرب المرفق اذا كانت البيانات كثيرة سوف يستغرق و قت اطول لأنه يقوم بتشييك صف صف كشفحساب.xls

ممكن لا مشكلة ان شاء الله

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

اذا المطلوب النقل الى شيت 2 من شيت 1 بدون التدخل الى شيت3 صح

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

جزاك الله خيرا

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

و عليكم السلام و رحمة الله وبركاته ما معنى من 1-2 و غيرها قليل من الشرح و التوضيح يفيد في الحل

وعليكم السلام و رحمة الله وبركاته اعتذر منك اخي الفاضل حاولت فتح الملف و لم اسنطيع تظهر نفس الرسالة في 2003 و 2010 و لم اتوصل للسبب

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

وعليكم السلام و رحمة الله وبركاته بعد اذن اخي الفاضل عاطف اخي الذيب لم تحدد في السؤال نوع ملحق الملف هل هو XLS او غير ذلك وما هو اصدار اوفيس او اكسل الذي تحاول الفتح للملف عليه 2003 -2007 - 2010 - 2013

و عليكم السلام و رحمة الله وبركاته قد يكون لا يوجد اي طابعة معرفة على الجهاز و الله اعلم

وعليكم السلام و رحمة الله وبركاته رائع و مبدع دائما اخي علي جزاك الله خيرا

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

السلام عليكم و رحمة الله وبركاته ابحث عن موضوع للأستاذ القدير طاهر اسمه مجمع البيانات في اكسل ان شاء الله تجد به ماتريد https://www.officena.net/ib/topic/38355-مكتبة-الموقع-مُجمِع-البيانات-للاكسيل-excel-data-collector/

السلام عليكم و رحمة الله وبركاته بعد الشكر و التقدير لكلا من اخوني الأفاضل زيزو و ali على الحلول الصحيحة و الرائعة التي قدموها ================================ هذا حل ثالث باستخدام التصفية المتقدمة بالكود اولا : الخانات الحمراء مهمة جدا لعمل الكود ثانيا : لن يقف في طريقك اي معلومة ناقصة اذا ادخلت اسم العميل فقط = تظهر لك بيانات هذا العميل في جميع المخازن اذا ادخلت اسم المخزن و تركت خانة اسم العميل فارغة = تظهر لك كل بيانات هذا المخزن لكل العملاء اذا تركت كلتا الخانتين فارغة = تظهر لك كل البيانات الموجودة في ورقة 1 Sub srsh() Dim RN1 As Range, RN2 As Range, RN3 As Range Set RN1 = Sheets("æÑÞÉ1").Range("A4:L99") Set RN2 = Sheets("æÑÞÉ2").Range("K1:L2") Set RN3 = Sheets("æÑÞÉ2").Range("A4:L99") RN1.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=RN2, CopyToRange:=RN3, Unique:=False End Sub كشف حساب عميل حسب المخزن.xlsm

السلام عليكم و رحمة الله وبركاته مرفق الشرح شرح كوود ترحيل.doc

و عليكم السلام استبدل الكوود السابق بالكوود الجديد

او جرب هذا الكوود الذي يؤدي نفس الغرض Sub macro1() ' Dim JNS, SAF, FSL Dim RN1 As Range Set RN1 = Range("A2:O555") JNS = Range("H1").Text SAF = Range("I1").Text FSL = Range("J1").Text Application.ScreenUpdating = False If JNS = "" Then RN1.AutoFilter Field:=8 Else RN1.AutoFilter Field:=8, Criteria1:=JNS End If If SAF = "" Then RN1.AutoFilter Field:=9 Else RN1.AutoFilter Field:=9, Criteria1:=SAF End If If FSL = "" Then RN1.AutoFilter Field:=10 Else RN1.AutoFilter Field:=10, Criteria1:=FSL End If Application.ScreenUpdating = True End Sub

السلام عليكم و رحمة الله وبركاته جرب اضافة خاصية منع تحديث الشاشة اثناء عمل الكود كما يلي Sub Filter_me() Rem========ÊÕÝíÉ ÌÏæá ÈÔÑØíä Application.ScreenUpdating = False Range("xfB1") = "ÇáÕÝ" Range("xfB2") = Range("i1") Range("xfC1") = "ÇáÌäÓ" Range("xfC2") = Range("H1") Range("xfD1") = "ÇáÝÕá" Range("xfD2") = Range("J1") On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Range("a2:L500").AdvancedFilter xlFilterInPlace, Range("xfB1:xfD2") Range("xfB1:xfD2") = vbNullString ThisWorkbook.Save Rem======== Application.ScreenUpdating = True End Sub

السلام عليكم و رحمة الله وبركاته تم التعديل لكود الترحيل وتم اضافة SUM(T6) للدالة في العمود AN و ان شاء الله تظبط هيك مرتب.rar

اعظم الله اجركم و احسن الله عزائكم و غفر الله لميتكم ===== كله محلول باذن الله نتابع لاحقا ان شاء الله

السلام عليكم الدالة =IF(COUNTIF('بدل نقدى1'!$B:$B;'155 كشف 1'!$A5)>0;"ب ن 1";ROUND(IF(B5="معلم مساعد";0;IF(بيانات!AU$4=1;0;بيانات!N4+بيانات!AR4+بيانات!AZ4));2)) و الكوود Sub t155_n1() ' Dim FS As Worksheet, TS As Worksheet Dim FR, TR, ER Set FS = Sheets("155 كشف 1") Set TS = Sheets("بدل نقدى1") ER = Application.CountA(FS.Range("A:A")) + 33 For FR = 5 To ER If FS.Cells(FR, 1).Value = "" Then GoTo 9 8 TR = TR + 1 If TS.Cells(TR, 2) <> "" Then GoTo 8 TS.Cells(TR, 2) = FS.Cells(FR, 1) TS.Cells(TR, 3) = FS.Cells(FR, 20) 9 Next End Sub جرب المرفق مرتب.xls مرتب.rar