بحث مخصص من جوجل فى أوفيسنا
Custom Search
  • اعلانات

    • محمد طاهر

      الكلمات المفتاحية   10 يون, 2017

      السلام عليكم الأخوة الكرام ، عند إضافة موضوع جديد يرجي الحرص على تحديد الكلمات المفتاحية فى الخانة تحت العنوان و هذا سيساهم فى تدعيم خاصية البحث و ربط الموضوع بالمواضيع الجديدة لتعم الفائدة برجاء الاهتمام بهذا الامر

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

أوفيسنا
  • Content count

    12,726
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    390

ياسر خليل أبو البراء last won the day on June 6

ياسر خليل أبو البراء had the most liked content!

السمعه بالموقع

7,176 Excellent

عن العضو ياسر خليل أبو البراء

  • الرتبه
    فريق الموقع

Profile Information

  • Gender (Ar)
    ذكر
  • Job Title
    Teacher
  • Location
    مصر
  • Interests
    Programming - Chess

Contact Methods

  • MSN
    yahk777@hotmail.com
  • Yahoo
    yakh777@yahoo.com

اخر الزوار

10,568 زياره للملف الشخصي
  1. بارك الله فيك أخي الكريم سيد والحمد لله أن تم المطلوب على خير ، والحمد لله الذي بنعمته تتم الصالحات تقبل وافر تقديري واحترامي وكل عام وأنت بخير
  2. أخي الكريم محمود كفكرة حاول بناء الملف من جديد بأسلوب مختلف .. كما ذكرت ضع المدخلات في ورقة عمل والمخرجات سيكون أمرها بسيط .. المهم هو شرح وتفصيل المطلوب افتح موضوع جديد لكل طلب .. ارفق ملف بسيط فيه بيانات معبرة عن الملف الأصلي وابدأ في العمل عليه ، واطرح لكل جزئية موضوع مستقل حتى تجد استجابة أفضل .. كن واضح المعالم وفصل الأمر بشكل جيد وارفق شكل النتائج المتوقعة وستجد من إخوانك بالمنتدى ما يسرك إن شاء الله ربما أتغيب الفترة القادمة (كل عام وأنتم بخير) .. وتقبل الله منا ومنكم
  3. No Comment Is Good Comment Regards
  4. أترفع الموضوع قبل رفع الآدان بوقتٍ قليل ... كل عام وأنت بخير أخي الحبيب أبو عبد الرحمن ، وننتظر مشاركات الأخوة الكرام بالموضوع
  5. لا أعرف طريقة العمل التي يسير بها ملفك لأقترح عليك تصميم محدد .. ولكن كنصيحة حاول أن تكون المدخلات في ورقة مستقلة بعيداً عن المخرجات نفسها وحاول أن تستخدم الأكواد بدلاً من المعادلات التي قد تثقل وترهق الملف بشكل كبير خصوصاً إذا كثرت أوراق العمل وكثرت البيانات أرجو أن يساعدك ذلك في حل مشكلتك إن شاء الله (رجاء يرجى عدم اقتباس الردود الطويلة لكي لا يطول الموضوع بدون داعي) تقبل وافر تقديري واحترامي وكل عام وأنت بخير
  6. الأفضل في حل أي مشكلة هو تناول نقطة نقطة .. حتى إذا انتهيت منها انتقلت لأخرى النقطة الأولى : شرح الماكرو : يعتمد الكود على عمل حلقة تكرارية لنطاق محدد ويطابق وجود نص معين .. لاحظت وجود النص "النسبة 1" في الجداول في الجزء الأول فقمت بالاعتماد عليها فإذا كانت الخلية تساوي النص المذكور ، يتم اختبار الخلية التالية (التي تقع تحت خلية العنوان "النسبة 1") فإذا كانت الخلية فارغة أو قيمتها تساوي صفر يتم وضع الخلية بامتداد 4 صفوف (عدد صفوف الجدول) في متغير من النوع نطاق بحيث يكون أسرع في التنفيذ ... وهكذا مع كل خلية داخل الحلقة التكرارية ، وفي نهاية المطاف يتكون لديك نطاق مجمع فيه الصفوف التي تم تطابق الشروط معها ونقوم بإخفاء الصفوف لذلك النطاق مرة واحدة لكل جزء وهذا أعتقد أسرع قليلاً النقطة الثانية : جهاز العمل لا يعمل إذا كان به كلمات عربي .. ما هي نسخة الأوفيس ونسخة الويندوز المنصبة عليه؟ جرب الصورة التالية لعلها تحل مشكلة جهاز العمل حاول تناقش نقطة نقطة .. لتجد استجابة أسرع من إخوانك بالمنتدى
  7. وعليكم السلام أخي الكريم في الحقيقة لا أحب تغيير هيكلة الملفات المرفقة حيث أن ذلك يلزمه تغير في الموضوع ... في الملف الجديد لاحظت أنك قمت بتحويل النطاقات إلى جداول في أوراق العمل "شيكات البنك العربي" و "شيكات البنك الاهلي" بينما ورقة العمل "شيكات البنك الفرنسي" لم يتم تحويلها لجدول .... انظر في الأوراق المذكورة في نهايتها ستجد بيانات في آخر الجدول وليس داخل الجدول .. لذا أولاً يجب ضبط الملف ومسح البيانات الموجودة في آخر الأوراق والتي توجد خارج نطاق الجدول .. وأيضاً قم بتحويل النطاق في آخر ورقة "شيكات البنك الفرنسي" إلى جدول لتكون الأوراق بنفس الهيكل ... ثم قم بحذف الأكواد التي لديك كلها واستخدم كود واحد فقط الذي سأدرجه لك الآن ... وها هو الكود .. وبعد وضعه في موديول قم بربط الأزرار الموجودة في الأوراق المعنية بهذا الكود فقط ... لا تقم بنسخ الكود ثلاثة مرات كما هو مرفق في ملفك بل استخدم الكود مرة واحدة فقط للثلاثة أوراق Option Explicit Sub TransferBankDetails() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Application.ScreenUpdating = False Set ws = ActiveSheet Set sh = ThisWorkbook.Sheets("شيكات " & ActiveSheet.Name) If Left(ws.Name, 5) <> "البنك" Then Exit Sub lr = sh.Cells(LastTableRow(sh), 1).End(xlUp).Row + 1 sh.Cells(lr, 1).Value = ws.Range("B2").Value sh.Cells(lr, 2).Value = ws.Range("D7").Value sh.Cells(lr, 3).Value = ws.Range("A8").Value sh.Cells(lr, 5).Value = ws.Range("F10").Value Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub Function LastTableRow(Optional ByVal TableSheet As Worksheet) As Long Dim Table As ListObject Dim LastRow As Long If TableSheet Is Nothing Then If ActiveSheet Is Nothing Then Exit Function Set TableSheet = ActiveSheet End If For Each Table In TableSheet.ListObjects If Table.DataBodyRange Is Nothing Then LastRow = WorksheetFunction.Max(Table.InsertRowRange.Row + 1, LastRow) Else LastRow = WorksheetFunction.Max(Table.ListRows(Table.ListRows.Count).Range.Row, LastRow) End If If Table.ShowTotals Then LastRow = LastRow + 1 Next Table LastTableRow = LastRow End Function
  8. أخي الكريم محمود المشكلة في هيكلة الملف .. غير مريحة للعمل عليها في الحقيقة عموماً جرب الكود التالي عله يفي بالغرض Sub Test() Dim rng As Range Dim cel As Range Application.ScreenUpdating = False With ActiveSheet .Rows("12:131").Hidden = False If Not IsEmpty(.Range("D4")) And Not IsEmpty(.Range("H4")) Then For Each cel In .Range("B12:B55") If cel.Value = "النسبة 1" Then If cel.Offset(1) = "" Or cel.Offset(1) = 0 Then If rng Is Nothing Then Set rng = cel.Resize(4) Else Set rng = Union(cel.Resize(4), rng) End If End If Next cel If Not rng Is Nothing Then rng.EntireRow.Hidden = True End If Else .Rows("12:55").Hidden = True End If If .Range("D55") = "" Or .Range("D55") = 0 Then .Rows("54:55").Hidden = True Set rng = Nothing: Set cel = Nothing '=============================================================== If Not IsEmpty(.Range("D5")) And Not IsEmpty(.Range("H5")) Then For Each cel In .Range("B56:B99") If cel.Value = "النسبة 2" Then If cel.Offset(1) = "" Or cel.Offset(1) = 0 Then If rng Is Nothing Then Set rng = cel.Resize(4) Else Set rng = Union(cel.Resize(4), rng) End If End If End If Next cel If Not rng Is Nothing Then rng.EntireRow.Hidden = True End If Else .Rows("56:99").Hidden = True End If If .Range("D99") = "" Or .Range("D99") = 0 Then .Rows("98:99").Hidden = True Set rng = Nothing: Set cel = Nothing '=============================================================== If Not IsEmpty(.Range("D6")) And Not IsEmpty(.Range("H6")) Then For Each cel In .Range("B100:B131") If cel.Value = "النسبة 3" Then If cel.Offset(1) = "" Or cel.Offset(1) = 0 Then If rng Is Nothing Then Set rng = cel.Resize(4) Else Set rng = Union(cel.Resize(4), rng) End If End If End If Next cel If Not rng Is Nothing Then rng.EntireRow.Hidden = True End If Else .Rows("100:131").Hidden = True End If If .Range("D104") = "" Or .Range("D104") = 0 Then .Rows("100:108").Hidden = True If .Range("D131") = "" Or .Range("D131") = 0 Then .Rows("129:131").Hidden = True Set rng = Nothing: Set cel = Nothing End With Application.ScreenUpdating = True End Sub
  9. وعليكم السلام وجزيت خيراً بمثل ما دعوت لي أخي الكريم أبو عبد الواحد والحمد لله أن تم المطلوب على خير ومشكور على دعائك الطيب .. تقبل تحياتي وكل عام وأنت بخير
  10. وعليكم السلام أخي الكريم أبو عبد الواحد في الملف المسمى "السجل" أدرج موديول جديد وضع الكود التالي فيه Sub ImportDataFromClosedWBs_YasserKhalil() Dim strFolder As String Dim strFile As String Dim wbk As Workbook Dim sh As Worksheet Dim lr As Long With Application .ScreenUpdating = False .Calculation = xlManual .DisplayAlerts = False .AskToUpdateLinks = False End With strFolder = ThisWorkbook.Path & "\الفواتير\" strFile = Dir(strFolder & "*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open(strFolder & strFile) Set sh = wbk.Worksheets(1) With ThisWorkbook.Worksheets(1) lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("A" & lr).Resize(1, 6).Value = sh.Range("A7").Resize(1, 6).Value .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value End With wbk.Close False strFile = Dir Loop With Application .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub
  11. اطلعت على الملف وحاولت فهم المطلوب . ومع الرغم من كثرة التفاصيل التي ذكرتها إلا أن الموضوع مبهم (خصوصاً أنك ذكرت أنك لا تريد كود لإخفاء الجداول الفارغة) المطلوب يلزمه كود ليقوم بعملية الإخفاء للصفوف الغير مرغوب فيها .. حاول ترفق شكل الورقة بعد إخفاء الجداول الغير مرغوب فيها كنموذج للإطلاع عليه
  12. بارك الله فيك أخي العزيز سليم إثراءً للموضوع إليك حل المشكلة بثلاثة طرق الأولى بطريقة يدوية بالشكل التالي والطريقة الثانية نفس الفكرة بالكود بدون حلقات تكرارية Sub SimpleReplace() With Columns(2) .Replace "2017", "", xlPart .Replace "~*", "", xlPart End With End Sub والطريقة الثالثة باستخدام المعادلات حيث يمكنك وضع المعادلة التالية في أي عمود فارغ بهذا الشكل =SUBSTITUTE(SUBSTITUTE(B1,"2017",""),"*","")
  13. السلام عليكم حاولت الإطلاع على الملف ولكنه لا يفتح .. قم بإزالة الأكواد الموجودة لديك وارفع الملف مرة أخرى لربما تجد من يساعدك بالأمر إن شاء الله
  14. بارك الله فيك أخي العزيز ناصر الكود يحتاج لوقت لمراجعته أولاً قبل التعديل عليه والوقت لا يتوفر بشكل كبير في هذه الفترة .. إن شاء الله في أقرب وقت سأحاول العمل على طلبك ويمكن للأخوة المشاركة والتعديل على الكود يما يتناسب مع طلبك .. وكل عام وأنت بخير
  15. وعليكم السلام أخي الكريم أبو حمادة ارفق ملف ليعمل عليه الأخوة الكرام حيث الموضوع مع إرفاق ملف يكون أجدر بسرعة الاستجابة