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

أخي الحبيب صلاح الصغير الموضوع أصغر مما تتخيل وأبسط مما تتخيل .. ضع المعادلة التالية في الخلية C13 =SUBTOTAL(9,C2:OFFSET(C14,-2,0)) بس خلاص جرب تدرج صفوف براحتك يا كبير !! شرح المعادلة : ------------ المعادلة زي ما إنت كاتبها .. شوف اللي اتغير !! وصلت تمام الحمد لله انتهى الشرح اللي اتغير بدل ما أحدد نهاية النطاق أخلي الإكسيل هو اللي يحدده ودا باستخدام الدالة Offset اللي بيسموها (دالة الإزاحة) الإزاحة بتبدأ منين من الخلية اللي تحت الخلية اللي بكتب فيها المعادلة وعدد صفوف الإزاحة صفين لفوق .. يعني اطلع صفين لفوق عشان كدا تلاقي الرقم بالسالب وعدد أعمدة الإزاحة صفر لأننا بنعمل إزاحة في نفس ذات العمود لا تنسى أن تحدد الإجابة كأفضل إجابة ليظهر الموضوع مجاب ومنتهي .. تقبل تحياتي :fff:

الأخ الكريم محبوب أعتذر عن التأخر في الرد عليك ، فقد كنت منشغلاً .. إليك الشرح عله يفيدك إن شاء الله Sub YasserKhalil() 'تعريف المتغيرات Dim WBK As Workbook Dim SH As Worksheet, WS As Worksheet, Cell As Range 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء خاصية رسائل التنبيه Application.DisplayAlerts = False 'سطر لفتح المصنف المسمى حسابات العملاء لجلب البيانات منه Set WBK = Workbooks.Open(ThisWorkbook.Path & "\حسابات العملاء.xlsx") 'حلقة تكرارية لكل أوراق العمل في المصنف الحالي الذي يحوي الكود For Each SH In ThisWorkbook.Sheets 'سطر لاستثناء ورقة العمل المسماة الفهرس من الحلقة التكرارية If SH.Name <> "الفهرس" Then 'مسح محتويات النطاقات المراد جلب البيانات إليها SH.Range("C6:F99,H6:I99").ClearContents 'حلقة تكرارية لكل أوراق العمل في المصنف المسمى حسابات العملاء For Each WS In WBK.Sheets 'سطر لاستثناء ورقة العمل المسماة الفهرس الرئيسي من الحلقة التكرارية If WS.Name <> "الفهرس الرئيسى" Then 'بدء التعامل مع كل ورقة عمل على حدا With WS 'إذا كانت أول خلية تحتوي على التواريخ فارغة يتم الانتقال لورقة العمل التالية If IsEmpty(.Range("A6")) Then GoTo 1 'سطر لتفادي حدوث خطأ أي استمرار عمل الكود في حالة حدوث خطأ On Error Resume Next 'حلقة تكرارية لنطاق التواريخ For Each Cell In .Range("A6:A" & .Cells(Rows.Count, 1).End(xlUp).Row) 'إذا كانت الخلية التي تحتوي على التاريخ ، الشهر بها يساوي رقم الشهر في ورقة العمل في المصنف الحالي 'وكذلك السنة الموجودة في التاريخ تساوي سنة 2015 يتم تنفيذ الأسطر التالية If Month(Cell.Value) = MonthNumber(SH.Name) And Year(Cell.Value) = 2015 Then 'يتم جلب التاريخ ووضعه في العمود الثامن في أوراق العمل في المصنف الحالي SH.Range("H" & SH.Cells(99, 8).End(xlUp).Row + 1) = Cell.Value 'يتم جلب اسم العميل ووضعه في العمود الثالث في أوراق العمل في المصنف الحالي SH.Range("C" & SH.Cells(99, 3).End(xlUp).Row + 1) = .Range("C2").Value 'يتم جلب قيمة القسط ووضعها في العمود الخامس في أوراق العمل في المصنف الحالي SH.Range("E" & SH.Cells(99, 5).End(xlUp).Row + 1) = Cell.Offset(, 2) 'يتم جلب قيمة الكوبري ووضعها في العمود السادس في أوراق العمل في المصنف الحالي SH.Range("F" & SH.Cells(99, 6).End(xlUp).Row + 1) = Cell.Offset(, 3) 'يتم جلب رقم التليفون ووضعه في العمود التاسع في أوراق العمل في المصنف الحالي SH.Range("I" & SH.Cells(99, 9).End(xlUp).Row + 1) = .Range("M8").Value 'انتهاء أسطر الشرط End If 'الانتقال للخلية التالية التي تحوي تاريخ Next Cell 'انتهاء التعامل مع ورقة العمل من المصنف المسمى حسابات العملاء استعداداً للتعامل مع ورقة عمل جديدة 1 End With End If 'الانتقال لورقة عمل جديدة في المنصف المسمى حسابات العملاء Next WS End If 'الانتقال لورقة عمل جديدة في المصنف الحالي Next SH 'إغلاق المصنف المسمى حسابات العملاء بدون حفظ التغييرات WBK.Close SaveChanges:=False 'إعادة تفعيل خاصية رسائل التنبيه Application.DisplayAlerts = True 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub تقبل تحياتي

الأخ الفاضل زوهير يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي التزاماً بالتوجيهات تقبل تحياتي

أخي الحبيب علاء رسلاااااااان الحمد لله تم بحمد الله وعونه وتوفيقه الانتهاء من المرحلة السابعة (كأننا بنركب فلتر مية .. ومش أي فلتر .. فلتر سبع مرااااااااااحل ) أخيراً انتهيت من هذا الملف اللي طلع عيني وخلاني مش شايف قدامي إليكم النسخة النهائية .. البيانات المفترض استخراجها تم استخراجها في ورقة عمل أخرى وهذا هو كود التجميع Sub FinalCollection() Dim I As Long, X As Long, Y As Long X = 2: Y = 3 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Sheets("Collector") .Range("A2:E10000").ClearContents For I = 1 To Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row Step 3 .Cells(X, "A").Value = Sheets("Data").Cells(I, "B").Value .Cells(X, "B").Value = Sheets("Data").Cells(I, "C").Value .Cells(X, "C").Value = Sheets("Data").Cells(I + 1, "F").Value .Cells(X, "D").Value = Sheets("Data").Cells(I + 2, "J").Value .Cells(X, "E").Value = Sheets("Data").Cells(I + 2, "K").Value .Cells(Y, "A").Value = Sheets("Data").Cells(I, "D").Value .Cells(Y, "B").Value = Sheets("Data").Cells(I, "E").Value .Cells(Y, "C").Value = Sheets("Data").Cells(I + 1, "G").Value .Cells(Y, "D").Value = Sheets("Data").Cells(I + 2, "L").Value .Cells(Y, "E").Value = Sheets("Data").Cells(I + 2, "M").Value X = X + 2 Y = Y + 2 Next I End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub أرجو أن ينفع الملف صاحبه الأخ بكري (اللي يبدو إنه نسي موضوعه تماماً أو يأس من عدم الوصول لحل ..) ولا يدري أنه بالإصرار يتحول المحال إلى ممكن ، وهذا كله بفضل الله وحده ثم بفضل الله وحده فلولا توفيق الله ما استطعت أن أخطو خطوة واحدة ولا أن أصل إلى ما وصلت إليه فاللهم لك الحمد ربي لك الحمد ملء السماوات والأرض وملء ما بينهما وملء ما شئت من شيء بعد .. اللهم لك الحمد كما ينبغي لجلال وجهك وعظيم سلطانك .. اللهم لك الحمد حتى ترضى ولك الحمد إذا رضيت ولك الحمد بعد الرضى .. اللهم لك الحمد كله ولك الشكر كله وإليك يرجع الأمر كله .. تقبلوا تحياتي أخوكم أبو البراء Filter Data V7.rar

بحمد الله وعونه وتوفيقه تم الانتهاء من المرحلة السادسة ..ألا وهي فصل أرقام البطاقات والأرقام السرية .. بقيت مرحلة واحدة ألا وهي تجميع البيانات التي تم استخراجها في صورة جدول منظم Filter Data V6.rar

أخي الفاضل زوهير إليك الملف المرفق عله يفي بالغرض Private Sub CommandButton2_Click() Unload Me End Sub Private Sub btnOK_Click() Dim WS As Worksheet Dim newRow As Long Set WS = Worksheets("Feuil1") With WS newRow = .Cells(Rows.Count, 1).End(3).Row + 1 .Cells(newRow, 1).Value = Cells(newRow, 1).Row - 8 .Cells(newRow, 2).Value = Me.TextBox1.Value .Cells(newRow, 3).Value = Me.TextBox2.Value .Cells(newRow, 4).Value = Me.TextBox3.Value .Cells(newRow, 5).Value = Me.TextBox4.Value End With Clear_Form End Sub Sub Clear_Form() Dim ctrl As Control Dim I As Long For Each ctrl In Me.Controls Select Case TypeName(ctrl) Case "TextBox" ctrl.Text = "" End Select Next ctrl End Sub تقبل تحياتي UserForm TextBox Input YasserKhalil.rar

يبدو أنه لا أحد يهتم عموماً قمت بضبط المخرجات قدر الإمكان . وبهذا نكون قد انتهينا من المرحلة الخامسة وإن شاء الله ليلاً سأكمل المرحلة السادسة ألا وهي فصل أرقام البطاقات والأرقام السرية في أعمدة منفصلة Filter Data V5.rar

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

الآن وصلنا للمرحلة الخامسة الجزء الأول هتستغربوا ليه قلت الجزء الأول ..لأنه لم يتم الانتهاء بعد من أرقام البطاقات والأرقام السرية أفضل نتيجة وصلت لها في الملف المرفق بعد عدة محاولات كلها باءت بالفشل أو النتائج الغير مرضية عموما تم فصل رقم البطاقة والرقم السري لكل شخص على حدا أي أن رقم البطاقة + الرقم السري لشخص في عمود ، ورقم البطاقة + الرقم السري في العمود المجاور إلا أنه نظراً لسوء إدخال البيانات فقد ظهرت بيانات أخرى في الأعمدة المجاورة فالتمس لمن لديه القدرة أن يقوم بضبط الأعمدة J و K أي يأخد البيانات الموجودة فيهما ويضعهما في المكان المناسب (شغل يدوي .. تظبيط يدوي لا بديل عنه) وهذا أفضل ما استطعت التوصل إليه من نتائج بخصوص هذه المرحلة .. بعدها في الجزء الثاني إن شاء الله سنعمل على العمودين H و I ونستخرج منها رقم البطاقة والرقم السري كل على حدا .. Filter Data V5.rar

أخي الحبيب علي .. ما التغيير الذي أحدثته في المصنف ؟ هل إظهار الصفوف وفقط أم أن هناك تعديلات أخرى ؟

المطلوب غير واضح أبن تريد زيادة المدى ؟ هل تقصد في كود محدد أم في ورقة العمل تريد إظهار الصفوف المخفية ؟

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

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

أخي الفاضل محبوب اعذرني لانشغالي إن شاء الله غداً سأحاول أن أفرغ بعض وقتي لشرح الكود ربنا ييسر الأمور تقبل تحياتي

أخي في الله علاء رسلان مشكور على متابعتك للموضوع .. ولولا متابعتك ما أكملت ما بدأته .. الأخ الغالي مختار الموقع الذي أعطيتني إياه جعلني أندم على عدم تدخلك من البداية لأن عملية التحويل كانت جيدة جدا بنسبة تصل لـ 80% لا تحرمنا من اقتراحاتك ------------------------------------------------------ وصلنا الآن للمرحلة الرابعة ..ألا وهي استخراج الأرقام المسلسلة وعدد الأفراد .. وبذلك نكون قد أتممنا تنقيح البيانات وإزالة الصفوف الغير مرغوب فيها وحذف المسافات الزائدة ، ووضع علامات الشرطة / في الأماكن المناسبة إلى آخر تلك الأمور من عملية التنقيح وأخيراً تم استخراج الأسماء والمسلسل وعدد الأفراد بقي رقم البطاقة والرقم السري .. وننتقل بعدها لمرحلة التجميع إن شاء الله Filter Data V4.rar

هل جربت المشاركة رقم 2 ورقم 3 ؟ جرب الاتنين وشوف لأني نسقت التاريخ وشغال عادي

ماله تنسيق التاريخ كليك يمين وبعدين Format cells واختر Date ونسق التاريخ كما يحلو لك

أو جرب الكود التالي Sub ImportWordTable() Dim wdDoc As Object Dim wdFileName As Variant Dim TableNo As Integer Dim iRow As Long Dim iCol As Integer Dim ResultRow As Long Dim TableStart As Integer Dim TableTot As Integer On Error Resume Next ActiveSheet.Range("A:AZ").ClearContents wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , "Browse for file containing table to be imported") If wdFileName = False Then Exit Sub Set wdDoc = GetObject(wdFileName) With wdDoc TableNo = wdDoc.tables.Count TableTot = wdDoc.tables.Count If TableNo = 0 Then MsgBox "This document contains no tables", _ vbExclamation, "Import Word Table" ElseIf TableNo > 1 Then TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & "Enter the table to start from", "Import Word Table", "1") End If ResultRow = 4 For TableStart = 1 To TableTot With .tables(TableStart) For iRow = 1 To .Rows.Count For iCol = 1 To .Columns.Count Cells(ResultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text) Next iCol ResultRow = ResultRow + 1 Next iRow End With ResultRow = ResultRow + 1 Next TableStart End With End Sub تقبل تحياتي

جرب الملف التالي أخي الفاضل صلاح Salah.rar

أخي راجع المشاركة رقم 25 وأجب عن كل الاستفسارات ... أين نموذج المخرجات ..!؟

جرب السطر التالي MsgBox Format(Day(CDate(ComboBox1.Value)), "dd")

أخي الحبيب أحمد مرجان الحمد لله ان تم المطلوب كما تريد وبعدين قولي تعرف لينا دي منين (لينا يا مرجان !!)

الأخ الفاضل رامي جمال الموضوع غير مطابق للمواصفات .. قم بالإطلاع على رابط التوجيهات http://www.officena.net/ib/index.php?showtopic=60147 لا تنسى أن تقوم بتغيير اسم الظهور للغة العربية

أخي الكريم الفارابي مشكور على كلماتك الطيبة .. صراحة لا أحبذ تحويل الحلقات إلى PDF نظراً لحدوث بعض الأخطاء ولكن يمكنك الاحتفاظ بالحلقات وتقرأها وأنت أوفلاين كما لو كنت أونلاين باستخدام إضافة للفايروكس الإضافة اسمها Mozilla Archive Format قم بتثبيت الإضافة قم بعمل ريستارت للفايرفوكس قم بالدخول على رابط الحلقات وانتظر حتى يكتمل التحميل تماماً .. روح لقايمة File في الفايرفوكس ستجد أمر اسمه Save Page In Archive As وسمي الملف وحدد مكان الحفظ واستمتع بدون الانترنت .. وإليك الملف المرفق للحلقات .. حلقات افتح الباب.rar

ما الخطأ الذي يظهر ..جربت المرفق الأخير ولم أجد أي خطأ