ياسر خليل أبو البراء

الأخ طارق الجزئية الأخيرة موجودة بالفعل اجعل الخلية C3 فارغة وجرب الكود

جرب =IF((C17>=5),0,C20-(C17*20))

تفضل أخي الفاضل أبو نبأ الملف التالي ..جرب الملف ووافنا بالنتائج Client Account Report YasserKhalil V3.rar

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

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

هل رقم الوصل المقصود به رقم الفاتورة .. جرب الملف التالي تم الاعتماد على رقم العميل ورقم الفاتورة واسم العميل كشرط لتصفية الحساب أي أنه كما في المرفق لن يتم إلا تصفية صف واحد من الثلاثة صفوف لأن أرقام الفواتير مختلفة Client Account Report YasserKhalil V2.rar

أخي الكريم أبو نبأ أخبرتك أني اعتمدت على التاريخ ...بمعنى التاريخ الموجود في ورقة تصفية حساب العميل في الخلية D3 هو أساس عملية تصفية البيانات .. بالنسبة لطلبك الثاني لم أقم بالتعديل في الكود ليناسب جلب البيانات الجديدة بعد ... فلتصبر إلى أن تنتهي من نقطة تصفية الحساب أولاً .. أكرر تصفية الحساب مرتبطة باسم العميل والتاريخ والمبلغ المدفوع والمستحق ..إذا تطابقت الشروط الأربعة تتم التصفية (وهذا أضمن ..) في انتظار ردك لا تتأخر علي

جرب الملف التالي ..تم عمل عمود مساعد في ورقة العمل "البيانات" وتم الاعتماد على أربعة شروط لتطبيق تصفية الحساب اسم العميل والتاريخ والمبالغ المستحقة والمدفوعة تكون مطابقة لما في ورقة العمل المسماة "تصفية حساب العميل" جرب الكود بتمعن وبدقة ووافنا بالنتائج Client Account Report YasserKhalil V2.rar

الموضوع صعب إلى حدٍ ما وسيتسبب في ثقل التعامل مع الملف ..أفضل أن تكتفي بما وصلنا إليه حيث أنه يؤدي المطلوب وفي حالة أردت إظهار قيمة عليك بالكتابة في العمود الأخير ..

أخي الكريم إليك الكود التالي بعد التعديل في الكود الموجود ليناسب طلبك Sub FindAllBills() Dim WS As Worksheet, SH As Worksheet Dim Arr, I As Long Set WS = Sheets("فاتورة"): Set SH = Sheets("استدعاء فاتورة") With Application .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False End With If IsEmpty(SH.Range("A3")) Then MsgBox "أدخل كود العميل المطلوب استدعاء فواتيره", 64: Exit Sub SH.Range("A4:N100000").Clear Arr = Split(FindRange(SH.Range("A3"), WS.Columns("C:C")), ",") For I = LBound(Arr) To UBound(Arr) On Error Resume Next If Month(WS.Range(Arr(I)).Offset(-3, -1)) = SH.Range("C3").Value Then WS.Range(Arr(I)).CurrentRegion.Copy SH.Range("A" & SH.Cells(Rows.Count, 1).End(3).Row + 2) ElseIf IsEmpty(SH.Range("C3").Value) Then WS.Range(Arr(I)).CurrentRegion.Copy SH.Range("A" & SH.Cells(Rows.Count, 1).End(3).Row + 2) End If Next I With Application .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True End With End Sub Function FindRange(FirstRange As Range, ListRange As Range) As String Dim aCell As Range, bCell As Range, oRange As Range Set oRange = ListRange.Find(what:=FirstRange.Value, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not oRange Is Nothing Then Set bCell = oRange: Set aCell = oRange Do Set oRange = ListRange.Find(what:=FirstRange.Value, After:=oRange, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not oRange Is Nothing Then If oRange.Address = bCell.Address Then Exit Do Set aCell = Union(aCell, oRange) Else Exit Do End If Loop FindRange = aCell.Address Else FindRange = "Not Found" End If End Function

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

أخي الكريم روح لمحرر الأكواد ..اعمل كليك يمين على الفورم الثاني UserForm2 ثم اختر الأمر View Code اضغط Ctrl + F من لوحة المفاتيح لتجد هذا السطر CommandButton2.Enabled = False غير القيمة False إلى True انتهى

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

بسم الله ما شاء الله تبارك الله روعة أخي الحبيب أبو عيد .. والله وحشتني هداياك .. ممكن إضافة بسيطة جداً .. بدل أن تضع كود في حدث كل ورقة عمل يمكن وضع كود واحد فقط بجانب كود الموديول بالطبع الكود يوضع في حدث المصنف ويتم حذف الأكواد الأخرى في أوراق العمل جميعها Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) On Error GoTo 1 'إذا كانت الصفحة محمية سيظهر خطأ في هذا الإجراء وعند ظهور الخطأ اذهب للرقم 1 بمعنى أنهاء العملية Range("XFD1") = "x" ' وضع إكس في الخلية لإحداث تغيير يتناسب مع حدث الصفحة If Intersect(Target, Range("XFD1")) Is Nothing Then ' إذا حصل التغيير في الخلية المحددة (وبدون أن أحددها) نفذ ما يأتي Call booom 'شغل هذا الماكرو من الموديول End If 1: End Sub تقبل وافر تقديري واحترامي

تفضل الكود التالي قمت ببعض التعديلات على الكود الاول ليناسب الإضافة التي أضفتها Sub TransferClientData() Dim WS As Worksheet, SH As Worksheet Dim LastRow As Long, LR As Long, I As Long Dim Arr Set WS = Sheets("تصفية حساب العميل"): Set SH = Sheets("ترحيل بيانات العميل") LastRow = WS.Cells(Rows.Count, "A").End(xlUp).Row - 3 LR = SH.Cells(Rows.Count, "B").End(xlUp).Row + 1 Arr = Array("B3", "E7", "B4", "A" & LastRow, "B" & LastRow, "C" & LastRow, "D3") With Application .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False End With If IsEmpty(Range("B3")) Or IsEmpty(Range("D3")) Or IsEmpty(Range("B4")) Or IsEmpty(Range("A6")) Then MsgBox "البيانات غير مكتملة", vbCritical: Exit Sub For I = 0 To UBound(Arr) SH.Cells(LR, I + 2) = WS.Range(Arr(I)) Next SH.Cells(LR, 1) = SH.Cells(LR, 1).Row - 1 With Application .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True End With MsgBox "تم ترحيل بيانات العميل بنجاح", 64 End Sub Client Account Report YasserKhalil.rar

في الخلية Q7 ضع المعادلة التالية =INDEX($I$12:$I$16,MATCH(S7,$J$12:$J$16,0)) إذا واجهتك مشكلة استبدل الفاصلة الموجودة في المعادلة بفاصلة منقوطة ثم قم بسحب المعادلة

الأخ الكريم أبو نبأ إليك الملف التالي ..قمت ببعض التعديلات لتحصل على النتائج منسقة بالكامل كل ما عليك كتابة رقم العميل ثم النقر على زر الأمر .. وجرب كتابة أرقام ليست موجودة .. Sub Treat() Dim WS As Worksheet, SH As Worksheet Dim FindName, LastRow As Long Set WS = Sheets("البيانات"): Set SH = Sheets("تصفية حساب العميل") With Application .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False End With With SH .Range("D3:E3,B4:D4").ClearContents .Range("A6:E1000").Clear FindName = Application.Match(.Range("B3").Value, WS.Columns(2), 0) If IsNumeric(FindName) Then .Range("B4").Value = WS.Cells(FindName, "E") Else MsgBox "No Mathing Data", 64: Exit Sub End If .Range("D3").Value = Date WS.AutoFilterMode = False WS.Rows(1).AutoFilter Field:=2, Criteria1:=.Range("B3").Value WS.Range("H1:I" & WS.Cells(Rows.Count, "E").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy .Range("A6").PasteSpecial xlPasteValues WS.AutoFilterMode = False LastRow = Selection.Rows.Count + 5 With .Range("A" & LastRow + 1 & ":" & "B" & LastRow + 1) .Formula = "=SUM(A7:A" & LastRow & ")" End With .Range("C" & LastRow) = "المبلغ المتبقي" .Range("C" & LastRow + 1) = .Range("A" & LastRow + 1) - .Range("B" & LastRow + 1) .Rows(1).Copy .Range("A" & LastRow + 4) .Rows(LastRow + 4).Hidden = False With .Range("A6:B" & LastRow + 1 & ",C" & LastRow & ":C" & LastRow + 1) .Range("A1:B1").Interior.Color = vbYellow .Font.Name = "Arial": .Font.Size = 13: .Font.Bold = True .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .Borders.LineStyle = xlDot: .BorderAround LineStyle:=xlDot End With .Range("C" & LastRow).Interior.Color = vbYellow .Range("B3").Select End With With Application .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True End With End Sub Client Account Report YasserKhalil.rar

أخي الكريم يرجى مراعاة الدقة عند إرفاق ملف والإطلاع على الكود المرفق (تم نسخ الكود بشكل غير لائق ..عموماً التعليقات غير مهمة بالنسبة لي ...ولكن لربما يقدم الحل شخص آخر فيجد التعليقات فيسهل عليه مساعدتك) عموم الأمر جرب الكود التالي Sub GetDataNew() Dim SummarySheet As Worksheet Dim FolderPath As String Dim NRow As Long Dim FileName As String Dim WorkBk As Workbook Dim LR As Long, X, I, Y, T As Long Set SummarySheet = ThisWorkbook.Worksheets("ورقة1") NRow = 2 Range("B2:C1000").ClearContents Application.ScreenUpdating = False For T = 1 To 13 FolderPath = ThisWorkbook.Path & "\" & T & "\" FileName = Dir(FolderPath & "*.xl*") Do While FileName <> "" And FileName <> ThisWorkbook.Name For I = 2 To 21 X = ExecuteExcel4Macro("len('" & FolderPath & "[" & FileName & "]ورقة1'!R" & I & "C2)") If Not IsError(X) Then If X > 0 Then SummarySheet.Range("B" & NRow).Value = ExecuteExcel4Macro("'" & FolderPath & "[" & FileName & "]ورقة1'!R" & I & "C2") SummarySheet.Range("C" & NRow).Value = ExecuteExcel4Macro("'" & FolderPath & "[" & FileName & "]ورقة1'!R" & I & "C4") NRow = NRow + 1 End If End If Next FileName = Dir() Loop Next T Range("A1").Select Application.ScreenUpdating = True End Sub

أخي الكريم المجلد فارغ ليس به ملفات

أخي الكريم يرجى دائماً بدل الرفع أن توضح بأسلوب آخر فقد يكون المطلوب مبهم أو يحتاج إلى مثال تطبيقي ..عموماً إليك الكود التالي في حدث الورقة حسب ما فهمت ... Private Sub Worksheet_Change(ByVal Target As Range) Dim Cell As Range If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 2 And Target.Column = 10 Then For Each Cell In Range("J1:Q1") If Cell.Value = Target.Value Then Cell.NumberFormat = ";;;" Next Cell End If If Target.Row > 2 And Target.Column = 15 Then For Each Cell In Range("J1:Q1") If Cell.Value = Target.Offset(, -5).Value Then Cell.NumberFormat = "General" Next Cell End If End Sub كود آخر يفي بالغرض بدون استخدام الحلقات التكرارية Private Sub Worksheet_Change(ByVal Target As Range) Dim Found As Range If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 2 And Target.Column = 10 Then Set Found = Range("J1:Q1").Find(What:=Target.Value, LookAt:=xlWhole) If Not Found Is Nothing Then Found.NumberFormat = ";;;" End If If Target.Row > 2 And Target.Column = 15 Then Set Found = Range("J1:Q1").Find(What:=Target.Offset(, -5).Value, LookAt:=xlWhole) If Not Found Is Nothing Then Found.NumberFormat = "General" End If End Sub Custom-Format-Worksheet-Change.rar

أخي الكريم ارفق الكود في ملف واشرح المطلوب وسنقوم بإذن الله بشرح الكود من خلال ملف تطبيقي

أخي الكريم أحمد علي النقطة الأولى : عدم السماح بالكتابة في خانة المبلغ الكلي والباقي الحل : روح للفورم نشط مربع النص "المبلغ الكلي" بعمل كليك شمال عليه وروح لنافذة الخصائص وغير قيمة الخاصية Enabled لتصبح False بدلاً من القيمة True نفس الكلام مع مربع النص "الباقي" ************************ النقطة الثانية : في حالة خانة الباقي تساوي صفر أو لاشيء يتم عدم تنشيط زر موافق الحل : ضع السطر التالي في حدث بدء الفورم Private Sub UserForm_Initialize() ضع هذا السطر في نهاية الإجراء قبل End Sub cmdOK.Locked = True أيضاً ضع الأسطر التالية في حدث Private Sub ComboBox3_Change() في نهاية الإجراء قبل End Sub أيضاُ ضع التالي If TextBox2 = "" Or TextBox2 = 0 Then cmdOK.Locked = True Else cmdOK.Locked = False End If *********************** سأكتفي بهاتين النقطتين .. لأن لا أحب الموضوع ذو الطلبات المتعددة .. يرجى طرح موضوع جديد ليشارك الجميع فيه تقبل تحياتي

وجزيت خيراً بمثله أخي الكريم عبد الموجود

بالنسبة للطلب الأول جربي الكود التالي Sub SequenceAllSheets() Dim SH As Worksheet, LR As Long For Each SH In Worksheets With SH LR = .Cells(Rows.Count, "C").End(xlUp).Row If .Cells(LR, "C") = "جمـــلة " Then LR = LR - 1 With .Range("A4:A" & LR) .NumberFormat = "General" .Formula = "=ROW()-3": .Value = .Value End With End With Next SH End Sub الطلب الثاني يخصص له موضوع مستقل

بدون ملف مرفق يصعب التخمين يرجى وضع نموذج ليساعدك الأخوة الكرام