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

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

أخي الكريم أبو إلياس وعليكم السلام ورحمة الله وبركاته باديء ذي بدء أحب أن أنوه إليك أن الملف غير مرضي بالنسبة لي كتنسيق .. لا تقم بتسطير كافة ورقة العمل بدون داعي .. فهذا يجعل الملف ثقيل في التعامل غير أن التسطير في حالتك غير ضروري ..فقط قم بتسطير النطاق المستخدم ... قمت بإزالة التسطير والاكتفاء بجزء من ورقة العمل لسهولة التعامل مع الملف أمر آخر إذا أردت أن ترفق ملف فينصح بوضع بعض البيانات الوهمية للعمل عليها ..قمت بوضع بعض البيانات في ملفك لاختبار النتائج للكود وأخيراً أرجو ألا تنزعج من نصحي ومن كلامي (الذي أراه جارحاً في كثير من الأحيان.. ولكن للضرورة أحكام) إليك الكود التالي يقوم بما تطلب إن شاء الله .. حاول تدرس أسطر الكود لتعرف كيفية التعديل عليه بما يتناسب مع ملفك الأصلي Sub TestYasser() Dim Ws As Worksheet, Sh As Worksheet Dim LR As Long, I As Long, Col As Long, LastRow As Long Set Ws = Sheets("Data"): Set Sh = Sheets("Result") LR = Ws.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False For I = 10 To LR For Col = 6 To 53 Step 8 LastRow = Sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 Sh.Cells(LastRow, "B").Resize(1, 4).Value = Ws.Cells(I, "B").Resize(1, 4).Value Sh.Cells(LastRow, "F").Resize(1, 8).Value = Ws.Cells(I, Col).Resize(1, 8).Value Next Col Next I Application.ScreenUpdating = True MsgBox "Finished...", 64 End Sub تقبل تحياتي Transfer Data Across Columns To Rows YasserKhalil.rar

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

إنت تؤمر أخي الكريم نايف المهم أن يستفيد الجميع لنبدأ مرحلة جديدة ... مرحلة غير المراحل السابقة نرى فيها الجميع يقدم إبداعاته بلا حدود تقبل تحياتي

أخي الكريم عبد العزيز المدني جرب الكود بهذا الشكل ليتناسب مع ملفك المرفق Sub TestRun() Dim I As Long For I = 8 To Cells(Rows.Count, "B").End(xlUp).Row If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "I") = Kh_Names(Cells(I, "B"), 2) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "I") = Kh_Names(Cells(I, "B"), 3) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) Cells(I, "I") = Kh_Names(Cells(I, "B"), 4) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) Cells(I, "H") = Kh_Names(Cells(I, "B"), 4) Cells(I, "I") = Kh_Names(Cells(I, "B"), 5) Else Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) Cells(I, "H") = Kh_Names(Cells(I, "B"), 4) Cells(I, "I") = Kh_Names(Cells(I, "B"), 5) End If Next I End Sub Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", "زين ") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function بالنسبة لنتائج الكود لن تكون صحيحة بسبب سوء البيانات المدخلة فمثلا الاسم ناصرسعدناصرمحمدالغيلي لا توجد أية مسافات في الاسم من ثم سيعامله الكود على أنه اسم واحد ويتم وضع كامل الاسم في خلية الاسم فقط يوجد مسافات كثيرة في الأسماء .. مثل صا لح (قم بإزالة مثل هذه المسافات) - هشا م - منا ل ... ويوجد أسماء كثيرة بهذا الشكل إذا أردت أن تحصل على نتائج صحيحة فلابد أن تكون المدخلات صحيحة تقبل تحياتي

أخي الكريم عبد العزيز المدني الملف محفوظ بصيغة xlsx وهذا الامتداد لا يحتفظ بالأكواد ..عندما تضع الكود وتحفظ ستظهر رسالة فيها كلمة Yes و No و Cancel انقر No سيظهر معك مربع حواري تحدد من خلاله اسم الملف والمكان المطلوب حفظ المصنف فيه وأهم شيء هو امتداد الملف اختار xlsm أو Excel Macro Enabled يمكنك الإطلاع على الموضوع التالي لتدرك بدايات التعامل مع الأكواد http://بداية الطريق لإنقاذ الغريق

أخي الغالي سعيد يبدو أنني قد فهمت المطلوب بعد الإمعان في الملف المرفق إليك الكود التالي عله يكون المطلوب ... رغم أنني لا أحبذ العمل على الاحتمالات بس إن شاء الله يكون المطلوب Sub TransferMatchingData() Dim WS As Worksheet, SH As Worksheet Dim Cel As Range, Found As Range Set WS = Sheet1: Set SH = Sheet3 Application.ScreenUpdating = False On Error Resume Next For Each Cel In WS.Range("B8:B" & WS.Cells(Rows.Count, "B").End(xlUp).Row) Set Found = SH.Range("B:B").Find(What:=Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Found Is Nothing And Not IsEmpty(Cel.Value) Then Found.Offset(, 1).Resize(1, 2).Value = Cel.Offset(, 1).Resize(1, 2).Value End If Next Cel Application.ScreenUpdating = True End Sub تقبل تحياتي

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

أخي الكريم حليم وعليكم السلام سؤالك الأول حول الموضوع الذي ندور فيه .. فيه كيفية عمل قائمة منسدلة وديناميكية أي تستجيب لعناصر جديدة يتم إضافتها السؤال الثاني المعادلات التي تظهر فيها الأقواس عبارة عن معادلات صفيف .. وعند التعديل في المعادلة وبعد الانتهاء من التعديل يتم الضغط على ثلاثة مفاتيح معاً وهي Ctrl + Shift + Enter ... تقبل تحياتي

أخي الكريم نايف إليك الكود التالي عله يكون المطلوب Sub Test() 'تعريف المتغيرات Dim Ws As Worksheet, Sh As Worksheet, Cel As Range, LR As Integer 'تعيين قيمة للمتغير ليساوي ورقة العمل المراد الترحيل منها Set Ws = Sheets("mm") 'تعيين قيمة للمتغير ليساوي ورقة العمل المراد الترحيل إليها Set Sh = Sheets("nn") 'تعيين الخلية التي سيتم ترحيل قيمتها Set Cel = Ws.Range("A1") 'تحديد أول خلية فارغة في العمود الأول في الورقة المراد الترحيل إليها LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 'شرط لاختبار تكرار القيمة باستخدام دالة العد بشرط 'فإذا كان ناتج العد أكبر من أو يساوي 1 ، فذلك يعني أن القيمة موجودة If Application.WorksheetFunction.CountIf(Sh.Columns(1), Cel.Value) >= 1 Then 'طالما أن القيمة موجودة تظهر رسالة تفيد بأن القيمة مكررة MsgBox "القيمة مكررة في العمود", 64 Else 'إذا لم تكن القيمة موجودة من قبل في الورقة المراد الترحيل إليها 'يتم وضع القيمة في أول خلية فارغة في العمود الأول بعد آخر خلية بها بيانات Sh.Range("A" & LR).Value = Cel.Value End If End Sub تقبل تحياتي

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

أخي الكريم صلاح إليك ملف عندي لا أعلم إذا كان هذا الملف يخص أخونا الحسامي رحمه الله وأدخله فسيح جناته ...أم لا قوائم جديدة لاي برنامج تصممه بنفسك.rar

وعليكم السلام إليك الملف الأخير قائمة منسدلة 4.rar

أخي الكريم سعيد بيرم جرب الكود التالي عله يفي بالغرض إن شاء الله Sub TransferData() Dim WS As Worksheet, SH As Worksheet Dim Area As Range, Rg As Range, Rng As Range Set WS = Sheet1: Set SH = Sheet3 Application.ScreenUpdating = False For Each Area In WS.Range("B8:D" & WS.Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(2).Areas Set Rg = Area.Offset(, -1).Resize(Area.Rows.Count, 3) If Rng Is Nothing Then Set Rng = Rg Else Set Rng = Union(Rng, Rg) Next Area Rng.Copy SH.Range("B" & SH.Cells(Rows.Count, "B").End(xlUp).Row).Offset(1).PasteSpecial xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي

أخي الكريم لما لا تستخدم الدالة Index انظر المرفق التالي (لعل المرفق الخاص بك به مشكلة) Test.rar

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

أخي الكريم سعيد والله أنا أريد تقديم المساعدة لكن اعذرني أشعر انني لا أدرك ولا أفهم طلبك بشكل جيد بعد خلينا في نقطة واحدة عشان نقدر نخطو خطوة للأمام سيبك من لغة التفاهم الغير مفهومة بالنسبة لي على الإطلاق .. سأخبرك ما فهمت للآن وأنت أكد لي ما هو صحيح أو صوب ما هو خطأ الورقة المراد الترحيل منها هي ورقة العمل المسماة "الفواتير الواردة" النطاق الذي سيتم الترحيل منه هو B8:D37 على أن ترحل الصفوف الغير فارغة في عمود الكميو والسعر .. أي يتم ترحيل الصفوف 9 - 10 - 11 - 14 - 16 -17 وهكذاا الورقة المراد الترحيل إليها هي ورقة العمل المسماة "القائمة العامة للمخازن" وأول خلية ترحل البيانات إليها هي أول خلية فارغة في العمود الثاني العمود B الأعمدة التي سيتم الترحيل إليها هي B و C و D فقط .. أرجو التأكيد أو التصحيح لما فهمت

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

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

أخي الكريم محمد يرجى وضع عنوان مناسب معبر عن الموضوع ... ضع المعادلة التالية في الخلية J7 =IF(B7>L7,0,+L7-B7) وضع المعادلة التالية في الخلية G7 =IF(L7>B7,0,+B7-L7) أرجو أن يفي ذلك بالغرض تقبل تحياتي

أخي الكريم ارفق الملف الأخير .. وارفق شكل النتائج المتوقعة ..اضرب مثال أو مثالين لتتضح الصورة

أخي الفاضل أحمد محمد الحمد لله أن تم المطلوب على خير .. وإلى لقاء في موضوعات أخرى تفيد جميع إخوانك بالمنتدى You're welcome .. يا ويلكم يا ويلكم تقبل تحياتي

أخي الكريم ياسر حمزة إليك محاولة مني لعلها تفي بالغرض تم إضافة عمود مساعد للجمع بين اسم المشروع والمواد . وعلى أساس هذا العمود المساعد يتم عمل ورقة عمل لكل مادة مميزة داخل المشروع .. جرب الملف المرفق بنفسك وشوف النتائج Sub Test() Dim A, I As Long, II As Long, myList, E, X, Flg As Boolean With Sheets("الادخال").Range("A4").CurrentRegion A = .Value For I = 2 To UBound(A, 1) For Each E In Split(A(I, 13), ",") If IsEmpty(myList) Then ReDim myList(1 To 2, 1 To 1) myList(1, 1) = Trim$(E) Set myList(2, 1) = .Rows(I): X = 1 Else For II = 1 To UBound(myList, 2) If myList(1, II) = Trim$(E) Then X = II: Flg = True: Exit For End If Next If Not Flg Then ReDim Preserve myList(1 To 2, 1 To II) myList(1, II) = Trim$(E) Set myList(2, II) = .Rows(I) X = II End If End If Set myList(2, X) = Union(myList(2, X), .Rows(I)) Flg = False Next Next For II = 1 To UBound(myList, 2) If Not IsSheetExists(myList(1, II)) Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = myList(1, II) .Rows(1).Copy Sheets(myList(1, II)).Cells(1) End If With Sheets(myList(1, II)) myList(2, II).Copy .Range("A" & Rows.Count).End(xlUp)(2) .Columns(13).EntireColumn.Delete .Cells(1).CurrentRegion.Columns.AutoFit End With Next End With End Sub Function IsSheetExists(ByVal txt As String) As Boolean On Error Resume Next IsSheetExists = Len(Sheets(txt).Name) On Error GoTo 0 End Function تقبل تحياتي Purchases Follow YasserKhalil.rar

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

أخي الكريم مهند الحمد لله أن تم المطلوب على خير .. وإلى لقاء في موضوعات أخرى تقبل وافر تقديري واحترامي