ابو حمادة قام بنشر مايو 8, 2016 مشاركة قام بنشر مايو 8, 2016 الكود من عمل الاستاذ الصقر اتمني ان اجد ما اريده الملف به كود استدعاء بيانات والكود يعمل بنسبة 100% ولكننى اريد تعديله ليتم ترك الصفوف الملونه باللون الاخضر اسفل كل صفحة حيث ان هذه الصفوف بها دالة جمع وتوقيع هذا ملف مرفق ولكم مني تحياتي استدعاء بيانات.rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 8, 2016 مشاركة قام بنشر مايو 8, 2016 أخي الكريم أبو حمادة هل أنت متأكد أن الكود لهذا الملف ؟؟إذ أنني اطلعت على الكود والملف غير منطقي بالنسبة للكود على الإطلاق .. أفضل توضيح الأمور كما يبنغي أن توضح تماماً الترحيل مسألة طرحت مئات المرات .. حدد ورقة العمل المراد الترحيل منها ، وحدد ورقة العمل المراد الترحيل إليها ، وحدد شروط الترحيل كلها ، وحدد النطاق المراد ترحيله وإلى أين يجب أن ترحل البيانات ، وما هو مصير البيانات الأصلية : هل يتم أخذ نسخة من البيانات مع الاحتفاظ بالنسخة الأصلية أم أن الترحيل مقرون بمسح البيانات الأصلية .. كل هذه أسئلة يجب أن تجيب عنها لتتضح الصورة ويساعدك الأخوة بالشكل المناسب .. تقبل تحياتي 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 8, 2016 الكاتب مشاركة قام بنشر مايو 8, 2016 شكرا لردك استاذي الفاضل بالفعل استاذ ياسر انا بعتذر بشده حيث انني راجعت الملف وتاكدت فعلا حصل لابس بين الاكواد بعتذر هذا الملف بعد المراجعه بالكود الصحيح وهذا هو الكود الذي اريد التعديل عليه Sub Find_All() Dim date1 As Double, date2 As Double Dim a, b, c As String a = Range("t2").Value: b = Range("u3").Value: c = Range("u2").Value d = Application.Match(c, Sheets("add").Range("A2:R2"), 0) Range("B6:R31").ClearContents Range("B37:R61").ClearContents date1 = Range("w2").Value2 date2 = Range("w3").Value2 Set Sh = Sheets("add") x = 6 With Sh For i = 1 To 65000 If b = CStr(.Cells(i, d)) And a = "الكل" Then Select Case .Cells(i, "o").Value2 Case date1 To date2 R = R + 1 If R = 26 Then R = 30 Cells(R + 5, "B").Resize(1, 18).Value = .Cells(i, "B").Resize(1, 18).Value End Select GoTo 1 End If If a = CStr(.Cells(i, "b")) And b = CStr(.Cells(i, d)) Then Select Case .Cells(i, "o").Value2 Case date1 To date2 R = R + 1 If R = 26 Then R = 30 Cells(R + 5, "B").Resize(1, 18).Value = .Cells(i, "B").Resize(1, 18).Value End Select End If 1: Next End With End Sub وهذا ملف اخر استدعاء بيانات.rar رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 21, 2016 الكاتب مشاركة قام بنشر مايو 21, 2016 اتمني حد يفدني في الموضوع دا هذا الملف المطلوب تعديل الكود عليه تعديل لاستدعاء البيانات_2.rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 21, 2016 مشاركة قام بنشر مايو 21, 2016 في ٨/٥/٢٠١٦ at 03:46, ياسر خليل أبو البراء said: أخي الكريم أبو حمادة هل أنت متأكد أن الكود لهذا الملف ؟؟إذ أنني اطلعت على الكود والملف غير منطقي بالنسبة للكود على الإطلاق .. أفضل توضيح الأمور كما يبنغي أن توضح تماماً الترحيل مسألة طرحت مئات المرات .. حدد ورقة العمل المراد الترحيل منها ، وحدد ورقة العمل المراد الترحيل إليها ، وحدد شروط الترحيل كلها ، وحدد النطاق المراد ترحيله وإلى أين يجب أن ترحل البيانات ، وما هو مصير البيانات الأصلية : هل يتم أخذ نسخة من البيانات مع الاحتفاظ بالنسخة الأصلية أم أن الترحيل مقرون بمسح البيانات الأصلية .. كل هذه أسئلة يجب أن تجيب عنها لتتضح الصورة ويساعدك الأخوة بالشكل المناسب .. تقبل تحياتي أجب عن الأسئلة في هذه المشاركة لابد من توضيح الطلب .. نصيحة لا تطلب تعديل على كود بدون شرح مفصل لآلية العمل .. وصدقني حتى ولو كنت أنا اللي كاتب الكود ، أكيد مش هعرف أفيدك غير لما أعرف ايه المشكلة بالضبط ..!! (لاحظ عدم استجابة الأخوة لمعظم موضوعاتك .. ليس تعنت لك والعياذ بالله ، ولكن لعدم وضوح المعطيات بشكل كامل ..أرجو أن تتفهم الأمر لكي تجد الاستجابة المطلوبة 2 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 21, 2016 الكاتب مشاركة قام بنشر مايو 21, 2016 1 دقيقه مضت, ياسر خليل أبو البراء said: أجب عن الأسئلة في هذه المشاركة لابد من توضيح الطلب .. نصيحة لا تطلب تعديل على كود بدون شرح مفصل لآلية العمل .. وصدقني حتى ولو كنت أنا اللي كاتب الكود ، أكيد مش هعرف أفيدك غير لما أعرف ايه المشكلة بالضبط ..!! (لاحظ عدم استجابة الأخوة لمعظم موضوعاتك .. ليس تعنت لك والعياذ بالله ، ولكن لعدم وضوح المعطيات بشكل كامل ..أرجو أن تتفهم الأمر لكي تجد الاستجابة المطلوبة انوه بس علي حاجه مهمه الكود يعمل بكفاءه عاليه 100% المطلوب استاذي الغالي ان يضاف امر الي الكود بحيث عند تبيق الكود يترك الصفوف الملونه باللون الاخضر اسفل كل صفحه كما هي لان هذه الصفوف تحتوى علي دوال لجلب التوقيعات ودالة جمع لقيم المبالغ اتمني اكون وضحت استاذ ياسر وقدرت اوصل المعلومه لمن يريد المساعده وجزاك الله خيرا رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 21, 2016 مشاركة قام بنشر مايو 21, 2016 إذاً الخلايا الخضراء ليست فارغة وبها معادلات أم أنها فارغة .. لما لا يكون الملف المرفق معبر عن الطلب حتى يسهل تقديم المساعدة المطلوبة .. لأن الخلايا الخضراء في المرفق فارغة وهذا من الممكن أن يجعلني أسلك مسلكاً آخر تماماً في عمل الكود !!! وللمرة مش عارف الكام أطلب التوضيح للطلب ، وأخبرتك لا تطلب تعديل على الكود وحسب .. لابد من توضيح المعطيات .. بشكل كامل ولكنك ما زلت مصراً على موقفك 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 21, 2016 الكاتب مشاركة قام بنشر مايو 21, 2016 9 دقائق مضت, ياسر خليل أبو البراء said: إذاً الخلايا الخضراء ليست فارغة وبها معادلات أم أنها فارغة .. لما لا يكون الملف المرفق معبر عن الطلب حتى يسهل تقديم المساعدة المطلوبة .. لأن الخلايا الخضراء في المرفق فارغة وهذا من الممكن أن يجعلني أسلك مسلكاً آخر تماماً في عمل الكود !!! وللمرة مش عارف الكام أطلب التوضيح للطلب ، وأخبرتك لا تطلب تعديل على الكود وحسب .. لابد من توضيح المعطيات .. بشكل كامل ولكنك ما زلت مصراً على موقفك اخي الكريم استاذ ياسر والله الملف كان به المعادلات التي ذكرتها في الصفوف الاسفل الملونه باللون الاخضر ولكن عند استخدام الكود تم مسح المعادلات ولصق البيانات بها المططلوب ان يعمل الكود ويتركها هذه الصفوف كما هي رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 21, 2016 مشاركة قام بنشر مايو 21, 2016 ممكن ترفق الملف الأصلي الذي يحتوي المعادلات التي لديك .. لإلقاء نظرة على الملف .. حسب ما فهمت ويا ريت تأكد فهمي أنك تقوم بترحيل البيانات بين تاريخين في الخلايا W2 و W3 ، وطبقاً للخلية U3 فقط ، فهل هناك شروط أخرى ؟ لما لا تستخدم الفلترة بدلاً من الحلقات التكرارية .. من فضلك وضح الشروط المطلوبة للترحيل أولاً وبعدها إن شاء الله نحل مشكلة الخلايا الخضراء 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 21, 2016 الكاتب مشاركة قام بنشر مايو 21, 2016 الان, ياسر خليل أبو البراء said: ممكن ترفق الملف الأصلي الذي يحتوي المعادلات التي لديك .. لإلقاء نظرة على الملف .. حسب ما فهمت ويا ريت تأكد فهمي أنك تقوم بترحيل البيانات بين تاريخين في الخلايا W2 و W3 ، وطبقاً للخلية U3 فقط ، فهل هناك شروط أخرى ؟ لما لا تستخدم الفلترة بدلاً من الحلقات التكرارية .. من فضلك وضح الشروط المطلوبة للترحيل أولاً وبعدها إن شاء الله نحل مشكلة الخلايا الخضراء بص ياستاذ ياسر الملف الاصلي كبير جدا وصعب يترفع هنا بالنسبه للترحيل فعلا كما ذكرت بيتم الترحيل بين تاريخيين وبالشروط الموجوده في الخليه U3 كما انت ذكرتها والكود الموجود يعمل بكفاءه ولكن عند جلب البيانات بيتم نسخها في جميع الصفوف ولا يترك الصفوف الملونه باللون الاخضر انا عايز اضيفه هو عند عمل الكود يتم ترك الصفوف الملونه باللون الاخضر اسفل كل صفحه فقط اتمني اكون قدرت اوصلك المعلومه رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 22, 2016 مشاركة قام بنشر مايو 22, 2016 أخي الكريم أبو حمادة يرجى فيما بعد في أي موضوعات قادمة أن يكون الملف المرفق معبر عن الملف الأصلي .. لاحظ أنني طلبت منك أكثر من مرة إرفاق ملف وفيه المعادلات في الخلايا الخضراء ولم تستجب ، فهل إذا لم تستجب لمطلبي ترى هل يمكن أن أستجيب لمطلبك ؟؟!! راعي الآخرين كما تحب أن يراعيك الآخرون جرب الكود التالي عله يفي بالغرض (الكود استغرق مني أكثر من 3 ساعات فلا تنسانا بدعوة بظهر الغيب) Sub Filter_Transfer_Data() Const nGroup As Long = 25 Const nInsert As Long = 3 Dim Ws As Worksheet, Sh As Worksheet Dim myDate1 As Date, myDate2 As Date Dim arr1 As Variant, arr2 As Variant Dim I As Long, J As Long, P As Long Set Ws = Sheets("add") Set Sh = Sheets("Aldata") Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets("Temp").Delete Sheets.Add.Name = "Temp" On Error GoTo 0 If IsDate(Sh.Range("W2")) And IsDate(Sh.Range("W3")) Then myDate1 = Sh.Range("W2"): myDate2 = Sh.Range("W3") myDate1 = DateSerial(Year(myDate1), Month(myDate1), Day(myDate1)) myDate2 = DateSerial(Year(myDate2), Month(myDate2), Day(myDate2)) End If With Ws .AutoFilterMode = False .Range("A2:R2").AutoFilter Field:=15, Criteria1:=">=" & myDate1, Operator:=xlOr, Criteria2:="<=" & myDate2 .Range("A2:R2").AutoFilter Field:=17, Criteria1:=Sh.Range("U3").Value .Range("A2").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1") .AutoFilterMode = False End With On Error Resume Next Sh.Range("A6:R10000").SpecialCells(xlCellTypeConstants).ClearContents arr1 = Sheets("Temp").Range("A1").CurrentRegion.Value I = ((UBound(arr1, 1) \ nGroup) + 1) * (nGroup + nInsert) arr2 = Sh.Range("A6").Resize(I, UBound(arr1, 2)).Formula For I = 1 To UBound(arr1, 1) P = P + 1 For J = 1 To UBound(arr1, 2) arr2(P, J) = arr1(I, J) Next J If I Mod nGroup = 0 Then P = P + nInsert Next I Sh.Range("A6").Resize(UBound(arr2, 1), UBound(arr2, 2)).Formula = arr2 Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub تقبل تحياتي 3 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 22, 2016 الكاتب مشاركة قام بنشر مايو 22, 2016 السلام عليكم استاذي القدير استاذ ياسر بجد مش عارف اشكرك ازى واقدر مجهودك الاكثر من رائع بصراحه كود مميز جدا جدا وانا بعتذر عن اني مكنتش قادر اوصل المعلومه ولكن فعلا مجهودك ال عملته دا جميل عمرى مهنساه بجد كود مميز جدا جدا جدا لكن هناك بعض الشروط لم تعمل استدعاء البيانات له عدة شروط ومعايير اولها ( بين التاريخيين الموجودين في نطاق ( W3:W2 ) هذا ملف مرفق اتمني ان يكون موضح به كل شئ به شرح وافي للمطلوب واعتذر بشده عن عدم التوضيح الكامل هذا الملف به شرح كامل وفورم البحث اتمني تركيب الكود عليه واسف للاطاله تعديل لاستدعاء البيانات.rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 22, 2016 مشاركة قام بنشر مايو 22, 2016 أخي الكريم أبو حمادة الحمد لله أن تم حل المشكلة بنسبة كبيرة لاحظت في الملف المرفق أنك قمت بزيادة عمود (لما لم تنوه عن الأمر ..فأي تعديل في الورقة يستلزم تعديل في الكود ومراجعة للكود من جديد .....!!!) بالنسبة للشروط فقد تم العمل عليها ..فقد تم العمل على الخلايا الخاصة بالتاريخ والخلية الخاصة V3 والتي كانت بالمرفق السابق U3 .. صراحة لا أدري الشروط إلى الآن بشكل واضح .. ممكن توضح المطلوب بمسميات الإكسيل .. يعني قول الخلية اللي عنوانها كذا بتجيب البياانات من العمود كذا اللي في ورقة العمل كذا لابد من وضع آلية للتوضيح لكي تستطيع التواصل بشكل أفضل ... أنا غير مستعد أن أقضي ساعات أخرى في حل ، لمجرد التخمين ملحوظة أخرى عمود الصنف في الملف القديم كان Q الآن في الملف الجديد بقدرة قادر أصبح رقمه 8 !!! فهلا استقررت على ملف واحد فقط للعمل عليه هل عرفت السبب الآن في عدم استجابة الأعضاء لموضوعاتك بشكل كبير لابد أن تعي أن الموضوع الجيد يحمل عنوان وااااااضح معبر عن الطلب ، به ملف مرفق واااااااضح ومعبر عن الملف الأصلي تماماً ، وبالموضوع شرح واضح لطلب واحد محدد وصريح ، ويكون الشرح بلغة الإكسيل أي ابتعد عن الشرح لمسميات طبيعة عملك فإذا كنت محاسب لا تتوقع مني أن أفهم اللغة الخاصة بالمحاسبة على الإطلاق ، ولكن اجعل اللغة التي تتحدث بها لغة الإكسيل (صف - عمود - خلية - نطاق - ورقة عمل ) ، والأفضل في معظم الحالات إرفاق شكل النتائج المتوقعة التي تزيل أي لبس بالموضوع تقبل تحياتي 2 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 22, 2016 الكاتب مشاركة قام بنشر مايو 22, 2016 39 دقائق مضت, ياسر خليل أبو البراء said: أخي الكريم أبو حمادة الحمد لله أن تم حل المشكلة بنسبة كبيرة لاحظت في الملف المرفق أنك قمت بزيادة عمود (لما لم تنوه عن الأمر ..فأي تعديل في الورقة يستلزم تعديل في الكود ومراجعة للكود من جديد .....!!!) بالنسبة للشروط فقد تم العمل عليها ..فقد تم العمل على الخلايا الخاصة بالتاريخ والخلية الخاصة V3 والتي كانت بالمرفق السابق U3 .. صراحة لا أدري الشروط إلى الآن بشكل واضح .. ممكن توضح المطلوب بمسميات الإكسيل .. يعني قول الخلية اللي عنوانها كذا بتجيب البياانات من العمود كذا اللي في ورقة العمل كذا لابد من وضع آلية للتوضيح لكي تستطيع التواصل بشكل أفضل ... أنا غير مستعد أن أقضي ساعات أخرى في حل ، لمجرد التخمين تقبل تحياتي تم المطلوب شرح وافي باسماء الاعمده والخلايا كما طلبت وهذا ملف مرفق به الشرح كاملا وشكر ليك لاهتمامك استاذي واخي الفاضل الاستاذ ياسر تعديل لاستدعاء البيانات.rar يوجد فورم للبحث بالملف لو اطلعت عليه سوف يقرب لك المطلوب اكثر ويوضحه اكثر رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 22, 2016 الكاتب مشاركة قام بنشر مايو 22, 2016 44 دقائق مضت, ابو حمادة said: تم المطلوب شرح وافي باسماء الاعمده والخلايا كما طلبت وهذا ملف مرفق به الشرح كاملا وشكر ليك لاهتمامك استاذي واخي الفاضل الاستاذ ياسر تعديل لاستدعاء البيانات.rar يوجد فورم للبحث بالملف لو اطلعت عليه سوف يقرب لك المطلوب اكثر ويوضحه اكثر منذ ساعه, ياسر خليل أبو البراء said: أخي الكريم أبو حمادة الحمد لله أن تم حل المشكلة بنسبة كبيرة لاحظت في الملف المرفق أنك قمت بزيادة عمود (لما لم تنوه عن الأمر ..فأي تعديل في الورقة يستلزم تعديل في الكود ومراجعة للكود من جديد .....!!!) بالنسبة للشروط فقد تم العمل عليها ..فقد تم العمل على الخلايا الخاصة بالتاريخ والخلية الخاصة V3 والتي كانت بالمرفق السابق U3 .. صراحة لا أدري الشروط إلى الآن بشكل واضح .. ممكن توضح المطلوب بمسميات الإكسيل .. يعني قول الخلية اللي عنوانها كذا بتجيب البياانات من العمود كذا اللي في ورقة العمل كذا لابد من وضع آلية للتوضيح لكي تستطيع التواصل بشكل أفضل ... أنا غير مستعد أن أقضي ساعات أخرى في حل ، لمجرد التخمين ملحوظة أخرى عمود الصنف في الملف القديم كان Q الآن في الملف الجديد بقدرة قادر أصبح رقمه 8 !!! فهلا استقررت على ملف واحد فقط للعمل عليه هل عرفت السبب الآن في عدم استجابة الأعضاء لموضوعاتك بشكل كبير لابد أن تعي أن الموضوع الجيد يحمل عنوان وااااااضح معبر عن الطلب ، به ملف مرفق واااااااضح ومعبر عن الملف الأصلي تماماً ، وبالموضوع شرح واضح لطلب واحد محدد وصريح ، ويكون الشرح بلغة الإكسيل أي ابتعد عن الشرح لمسميات طبيعة عملك فإذا كنت محاسب لا تتوقع مني أن أفهم اللغة الخاصة بالمحاسبة على الإطلاق ، ولكن اجعل اللغة التي تتحدث بها لغة الإكسيل (صف - عمود - خلية - نطاق - ورقة عمل ) ، والأفضل في معظم الحالات إرفاق شكل النتائج المتوقعة التي تزيل أي لبس بالموضوع تقبل تحياتي كدا الملف المطلوب استاذ ياسر ولا هناك حاجه غير موضحة اتمني الرد لكي اعرف انه هو المطلوب والشرح الوافي رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 22, 2016 الكاتب مشاركة قام بنشر مايو 22, 2016 ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 22, 2016 مشاركة قام بنشر مايو 22, 2016 أخي الكريم أبو حماده الرجاء الصبر حتى يرد أحد الأعضاء على آخر مشاركة لك .. بعد محاولة للعمل على الملف الأخير واجهتني مشكلة في عمود التاريخ ، وأحاول حلها الآن .. ففي الملف الأخير تنسيق التاريخ يبدو أنه تسبب في مشكلة ولم يعد يعمل مع الكود .. هل بإمكانك إرجاع التنسيق الخاص بالتاريخ كما كان بالملف الأصلي لأنني حاولت ولم يفلح الكود أيضاً .. ماذا غيرت في تنسيق التاريخ حيث أن الأمور أصبحت على غير طبيعتها فالكود يقرأ التاريخ بشكل والإكسيل بشكل آخر مما أحدث خللاً في الكود ..حيث على سبيل المثال 8 / 1 / 2016 أي الشهر هو يناير ، يقرأ على أنه 1 / 8 / 2016 أي شهر أغسطس ... الملف الأسبق لم يكن به تلك المشكلة جاري العمل عليها .. أو يمكنك الرجوع إلى التنسيق الأصلي في الملف الأسبق لمحاولة تفادي المشكلة 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 22, 2016 الكاتب مشاركة قام بنشر مايو 22, 2016 4 دقائق مضت, ياسر خليل أبو البراء said: أخي الكريم أبو حماده الرجاء الصبر حتى يرد أحد الأعضاء على آخر مشاركة لك .. بعد محاولة للعمل على الملف الأخير واجهتني مشكلة في عمود التاريخ ، وأحاول حلها الآن .. ففي الملف الأخير تنسيق التاريخ يبدو أنه تسبب في مشكلة ولم يعد يعمل مع الكود .. هل بإمكانك إرجاع التنسيق الخاص بالتاريخ كما كان بالملف الأصلي لأنني حاولت ولم يفلح الكود أيضاً .. ماذا غيرت في تنسيق التاريخ حيث أن الأمور أصبحت على غير طبيعتها فالكود يقرأ التاريخ بشكل والإكسيل بشكل آخر مما أحدث خللاً في الكود ..حيث على سبيل المثال 8 / 1 / 2016 أي الشهر هو يناير ، يقرأ على أنه 1 / 8 / 2016 أي شهر أغسطس ... الملف الأسبق لم يكن به تلك المشكلة جاري العمل عليها .. أو يمكنك الرجوع إلى التنسيق الأصلي في الملف الأسبق لمحاولة تفادي المشكلة شكر لك اخي الفاضل استاذ ياسر وان كان تنسيق التاريخ يسبب مشكله انا عامل تنسيق عمود التاريخ ليكن ( التاريخ والتوقيت) لو كان هناك مشكله في هذا التنسيق ممكن حضرتك تنسقه كما في الملف السابق ولكن اضافة عمود جمب عمود التاريخ ليضاف به التوقيت ولك مني جزيل الشكر والاحترام رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 22, 2016 مشاركة قام بنشر مايو 22, 2016 هلا قمت بالأمر لأنني لدي مشاغل كثيرة الآن وبعد العمل على الملف قم برفعه مرة أخرى للعمل عليه إن شاء الله 1 رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 22, 2016 مشاركة قام بنشر مايو 22, 2016 جرب الكود التالي عله يفي بالغرض ويحل المشكلة تماماً Sub Find_All() Const nGroup As Long = 25 Const nInsert As Long = 3 Dim Ws As Worksheet, Sh As Worksheet Dim myDate1 As Double, myDate2 As Double Dim arr1 As Variant, arr2 As Variant Dim I As Long, J As Long, P As Long, mCol As Long Set Ws = Sheets("add") Set Sh = Sheets("Aldata") Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets("Temp").Delete Sheets.add.Name = "Temp" On Error GoTo 0 If IsDate(Sh.Range("W2")) And IsDate(Sh.Range("W3")) Then myDate1 = Sh.Range("W2"): myDate2 = Sh.Range("W3") End If With Sh If .Cells(Rows.Count, 2).End(xlUp).Row > 5 Then .AutoFilterMode = False .Range("B5:S5").AutoFilter Field:=1, Criteria1:="<>" .Range("B6:S" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeVisible).ClearContents .AutoFilterMode = False End If End With With Ws .AutoFilterMode = False .Range("A2:S2").AutoFilter Field:=4, Criteria1:=">=" & myDate1, Operator:=xlOr, Criteria2:="<=" & myDate2 If Sh.Range("U3").Value <> "الكل" Then .Range("A2:S2").AutoFilter Field:=2, Criteria1:=Sh.Range("U3").Value mCol = Application.Match(Sh.Range("V2").Value, .Rows(2), 0) .Range("A2:S2").AutoFilter Field:=mCol, Criteria1:=Sh.Range("V3").Value .Range("A2").CurrentRegion.Offset(2).SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1") .AutoFilterMode = False End With Sheets("Temp").Columns(1).Delete arr1 = Sheets("Temp").Range("A1").CurrentRegion.Value I = ((UBound(arr1, 1) \ nGroup) + 1) * (nGroup + nInsert) arr2 = Sh.Range("A6").Resize(I, UBound(arr1, 2)).Formula For I = 1 To UBound(arr1, 1) P = P + 1 For J = 1 To UBound(arr1, 2) arr2(P, J) = arr1(I, J) Next J If I Mod nGroup = 0 Then P = P + nInsert Next I Sh.Range("B6").Resize(UBound(arr2, 1), UBound(arr2, 2)).Formula = arr2 Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub تقبل تحياتي 2 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 23, 2016 الكاتب مشاركة قام بنشر مايو 23, 2016 شكرا استاذ ياسر علي هذا المجهود ومتاسف للاطالة هذا الكود يعمل جيدا ولكن به بعض الملاحظات 1- عند البحث علي شئ غير موجود بالورقة يظهر خطأ ويتم مسح البيانات الموجوده في النطاق ( B5:S5 ) عناوين الصفوف وانا محدده هذا النطاق باللون الاصفر لكي تعرفه وفي بعض الاحيان اثناء التجربه تم مسح الناق من ( B4:S4 ) وهذا النطاق حددته ايضا باللون الاصفر 2- اذا تم تحديد نوع البحث وتم الضغط علي زر البحث مرتين ورا بعض لاحظت انه بيتم نسخ المعادلات الموجوده في العمود ( A ) في العمودين ( B ) و ( C ) مرفق ملف به الكود ارجو النظر اليه وتجربة الكود وسوف ترى الملاحظات تعديل لاستدعاء البيانات1.rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 23, 2016 مشاركة قام بنشر مايو 23, 2016 جرب التعديل التالي رغم أن الكود يعمل لدي ولم ألاحظ المشكلات التي تتحدث عنها ، عموماً قم بتجربة الكود مرة أخرى بعد التعديل وإذا وجدت ملاحظات فيرجى ذكر ملحوظة واحدة فقط في كل مرة للتركيز عليها ومعالجتها ..لأن الكود طويل ويحتاج لتدقيق ... بدأت أفقد السيطرة على الكود Sub Find_All() Const nGroup As Long = 25 Const nInsert As Long = 3 Dim Ws As Worksheet, Sh As Worksheet Dim myDate1 As Double, myDate2 As Double Dim arr1 As Variant, arr2 As Variant Dim I As Long, J As Long, P As Long, mCol As Long Set Ws = Sheets("add") Set Sh = Sheets("Aldata") Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets("Temp").Delete Sheets.add.Name = "Temp" On Error GoTo 0 If IsDate(Sh.Range("W2")) And IsDate(Sh.Range("W3")) Then myDate1 = Sh.Range("W2"): myDate2 = Sh.Range("W3") End If With Sh If .Cells(Rows.Count, 2).End(xlUp).Row > 5 Then .AutoFilterMode = False .Range("B5:S5").AutoFilter Field:=1, Criteria1:="<>" .Range("B6:S" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeVisible).ClearContents .AutoFilterMode = False End If End With With Ws .AutoFilterMode = False .Range("A2:S2").AutoFilter Field:=4, Criteria1:=">=" & myDate1, Operator:=xlOr, Criteria2:="<=" & myDate2 If Sh.Range("U3").Value <> "الكل" Then .Range("A2:S2").AutoFilter Field:=2, Criteria1:=Sh.Range("U3").Value mCol = Application.Match(Sh.Range("V2").Value, .Rows(2), 0) .Range("A2:S2").AutoFilter Field:=mCol, Criteria1:=Sh.Range("V3").Value .Range("A2").CurrentRegion.Offset(2).SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1") .AutoFilterMode = False End With Sheets("Temp").Columns(1).Delete arr1 = Sheets("Temp").Range("A1").CurrentRegion.Value On Error GoTo Skipper I = ((UBound(arr1, 1) \ nGroup) + 1) * (nGroup + nInsert) arr2 = Sh.Range("A6").Resize(I, UBound(arr1, 2)).Formula For I = 1 To UBound(arr1, 1) P = P + 1 For J = 1 To UBound(arr1, 2) arr2(P, J) = arr1(I, J) Next J If I Mod nGroup = 0 Then P = P + nInsert Next I Sh.Range("B6").Resize(UBound(arr2, 1), UBound(arr2, 2)).Formula = arr2 Skipper: Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub لا تنسى وضع ملاحظة واحدة فقط للعمل عليها .. مع وضع وإرفاق ملف أصلي لم يتم تنفيذ الكود عليه ، أي قم بتجربة الكود ولكن بدون حفظ على الملف حتى أرى المشكلة التي تحدث بعيني .. مع ذكر متى تحدث المشكلة بالضبط ؟ 2 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 23, 2016 الكاتب مشاركة قام بنشر مايو 23, 2016 انا فعلا والله مش عارف المشكله ايه سببها انا طبقت الكود الاخير ومازال نفس الخطا ضع الكود علي هذا الملف تعديل لاستدعاء البيانات1.rar واعمل الاتى اكتب في الخلية ( V2 ) كلمة ( القسم ) وفي الخليه ( V3 ) اكتب (ح-ع ) واضغط مرة واحدة علي مفتاح البحث ولاحظ النتيجة بعد اخر خليه بها بيانات في العمود ( B ) و العمود ( C ) كرر الضغط مرتين مثلا وكل مره شوف الفرق ال بيحصل بدون ماتغير اي بيانات في البحث ثم اكتب في الخلية ( V2 ) كلمة ( القسم ) وفي الخليه ( V3 ) اكتب ( 444 ) واضغط علي مفتاح البحث ولاحظ النتيجة سوف تظهر رسالة بالخطأ كنسلها واضغط تاني علي مفتاح البحث سوف يتم مسح الصف رقم 5 المظلل باللون الاصفر واذا تم الضغط علي بحث مره اخري سوف يتم مسح الصف رقم 4 الملون باللون الاصفر رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 24, 2016 مشاركة قام بنشر مايو 24, 2016 أخي الكريم أبو حمادة يبدو لي أنك تقوم بتغييرات في الكود .. مما يتسبب في حدوث مشاكل إليك الملف المرفق التالي لم يتم فيه تنفيذ الكود .. يعني نسخة أصلية كما أرفقتها في مشاركة سابقة .. جرب الملف وأعطي ملاحظاتك !! انقر على صورة "إنا فتحنا لك فتحاً مبيناً" ... لو فيه أية ملاحظات يرجى ذكر ملاحظة واحدة فقط .. وتذكر كيف حدثت المشكلة ؟ أي ما هي الإدخالات التي سببت المشكلة؟ لن ارفق أكواد .. سأرفق ملف مرفق وأمري لله Filter Data By Dates & Transfer Skipping Formula Rows YasserKhalil.rar تم تعديل الملف المرفق .. دعك من الإصدار الأول للملف ..جرب الملف التالي (الإصدار الثاني) حيث اكتشفت بعض الأخطاء وتمت معالجتها إن شاء الله Filter Data By Dates & Transfer Skipping Formula Rows YasserKhalil V2.rar 2 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 24, 2016 الكاتب مشاركة قام بنشر مايو 24, 2016 7 ساعات مضت, ابو حمادة said: تسلم يامبدع الله ينور عليك بجد هو دا المطلوب مش عارف اشكرك ازاى علي قد المجهود التي قمت به ادعي الله عز وجل في هذه الايام المباركه ان يبارك لك في علمك وعملك وان يجازيك خيرا في اهلك وان يجعل هذا العمل في ميزان حسناتك تحيه وتقدير لك مني ومتاسف لو كان الموضوع اخد وقت طويل من وقتك ومجهودك 9 ساعات مضت, ياسر خليل أبو البراء said: جرب التعديل التالي رغم أن الكود يعمل لدي ولم ألاحظ المشكلات التي تتحدث عنها ، عموماً قم بتجربة الكود مرة أخرى بعد التعديل وإذا وجدت ملاحظات فيرجى ذكر ملحوظة واحدة فقط في كل مرة للتركيز عليها ومعالجتها ..لأن الكود طويل ويحتاج لتدقيق ... بدأت أفقد السيطرة على الكود Sub Find_All() Const nGroup As Long = 25 Const nInsert As Long = 3 Dim Ws As Worksheet, Sh As Worksheet Dim myDate1 As Double, myDate2 As Double Dim arr1 As Variant, arr2 As Variant Dim I As Long, J As Long, P As Long, mCol As Long Set Ws = Sheets("add") Set Sh = Sheets("Aldata") Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets("Temp").Delete Sheets.add.Name = "Temp" On Error GoTo 0 If IsDate(Sh.Range("W2")) And IsDate(Sh.Range("W3")) Then myDate1 = Sh.Range("W2"): myDate2 = Sh.Range("W3") End If With Sh If .Cells(Rows.Count, 2).End(xlUp).Row > 5 Then .AutoFilterMode = False .Range("B5:S5").AutoFilter Field:=1, Criteria1:="<>" .Range("B6:S" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeVisible).ClearContents .AutoFilterMode = False End If End With With Ws .AutoFilterMode = False .Range("A2:S2").AutoFilter Field:=4, Criteria1:=">=" & myDate1, Operator:=xlOr, Criteria2:="<=" & myDate2 If Sh.Range("U3").Value <> "الكل" Then .Range("A2:S2").AutoFilter Field:=2, Criteria1:=Sh.Range("U3").Value mCol = Application.Match(Sh.Range("V2").Value, .Rows(2), 0) .Range("A2:S2").AutoFilter Field:=mCol, Criteria1:=Sh.Range("V3").Value .Range("A2").CurrentRegion.Offset(2).SpecialCells(xlCellTypeVisible).Copy Sheets("Temp").Range("A1") .AutoFilterMode = False End With Sheets("Temp").Columns(1).Delete arr1 = Sheets("Temp").Range("A1").CurrentRegion.Value On Error GoTo Skipper I = ((UBound(arr1, 1) \ nGroup) + 1) * (nGroup + nInsert) arr2 = Sh.Range("A6").Resize(I, UBound(arr1, 2)).Formula For I = 1 To UBound(arr1, 1) P = P + 1 For J = 1 To UBound(arr1, 2) arr2(P, J) = arr1(I, J) Next J If I Mod nGroup = 0 Then P = P + nInsert Next I Sh.Range("B6").Resize(UBound(arr2, 1), UBound(arr2, 2)).Formula = arr2 Skipper: Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub لا تنسى وضع ملاحظة واحدة فقط للعمل عليها .. مع وضع وإرفاق ملف أصلي لم يتم تنفيذ الكود عليه ، أي قم بتجربة الكود ولكن بدون حفظ على الملف حتى أرى المشكلة التي تحدث بعيني .. مع ذكر متى تحدث المشكلة بالضبط ؟ 6 ساعات مضت, ياسر خليل أبو البراء said: أخي الكريم أبو حمادة يبدو لي أنك تقوم بتغييرات في الكود .. مما يتسبب في حدوث مشاكل إليك الملف المرفق التالي لم يتم فيه تنفيذ الكود .. يعني نسخة أصلية كما أرفقتها في مشاركة سابقة .. جرب الملف وأعطي ملاحظاتك !! انقر على صورة "إنا فتحنا لك فتحاً مبيناً" ... لو فيه أية ملاحظات يرجى ذكر ملاحظة واحدة فقط .. وتذكر كيف حدثت المشكلة ؟ أي ما هي الإدخالات التي سببت المشكلة؟ لن ارفق أكواد .. سأرفق ملف مرفق وأمري لله Filter Data By Dates & Transfer Skipping Formula Rows YasserKhalil.rar انا فعلا مش عارف اشكرك ازى لاهتمامك بالامر واتمني من الله عز وجل ان يجعله في ميزان حسناتك وان يبارك لك في علمك ملحوظة انا لم اغير اي شئ في الكود ولا في الملف بالنسبه للملف ال حضرتك ارسلته فيه ملاحظة واحده فقط هي ان نسخ البيانات عمود ( A ) بيجي فيه النوع ( شراء ) رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان