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

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

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

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

أخي الكريم سعيد بيرم بارك الله فيك وجزيت خيراً على كلماتك الرقيقة في حقي وجزيت خيراً على دعواتك الطيبة المباركة تقبل وافر تقديري واحترامي

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

أخي الكريم كمال بالنسبة لسؤالك الأول كيف يمكن جعل الماكرو يعمل تلقائياً عن فتح المصنف .. قم بالإطلاع على المرفق في المشاركة الأخيرة لي وادخل على نافذة المشروع ودبل كليك على ThisWorkbook لتجد الكود المناسب .. يتم وضع الكود في حدث المصنف بالنسبة لسؤالك الثاني يمكنك تغيير المسار من خلال السطر التالي في الكود (في السطر يتم التعامل مع المصنفات في نفس المسار الحالي للمصنف) FolderPath = ThisWorkbook.Path & "\" أما عن عدم عمل الكود مع المسميات العربية فربما تكون أسماء أوراق العمل لديك باللغة العربية ..فيجب تغيير كلمة Sheet1 في الكود والتي تقع بين أقواس تنصيص بكلمة ورقة1 لو واجهتك أي مشكلة قم بإرفاق ملفك الذي به المشكلة ليسهل الإطلاع على المشكلة وتوجيهك نحو التعديل المناسب تقبل تحياتي

أخي الكريم حسن أهلاً بك في المنتدى ونورت بين إخوانك جرب الكود التالي سيتم وضع أول أربعة حروف في الخلية A1 .. Sub Test() Range("A1").Value = Mid(ActiveWorkbook.Name, 1, 4) End Sub إذا لم يؤدي الكود الغرض فيرجى إرفاق ملف أو مزيد من التوضيح تقبل تحياتي

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

أخي الكريم إبراهيم لست متابع للموضوع من البداية ، ولكن من خلال رد أخي الغالي رجب الأخير أفهم أن المشكلة في وجود ورقة العمل من عدم وجودها لما لا تستخدم دالة معرفة تقوم بالأمر نيابةً عنك ومن خلالها يمكنك تجنب الخطأ ادرس الكود التالي جيداً وحاول تستفيد منه Sub TestRun() If Not SheetExists("Sheet1") Then MsgBox "The worksheet does not exist.", vbExclamation Else MsgBox "The worksheet already exists.", vbInformation End If End Sub Function SheetExists(strName As String) As Boolean Dim WS As Excel.Worksheet On Error Resume Next Set WS = Sheets(strName) SheetExists = (Err.Number = 0) Set WS = Nothing End Function تقبل تحياتي

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

أخي الكريم سعيد دعك من المشاركة السابقة وإليك الأكواد التالية ..يمكنك الآن الاستغناء عن الأكواد في حدث ورقة العمل لأنني لا أحبذها أصلاً طالما أنه بالإمكان عمل المطلوب دونها جرب الكودين التاليين أحدهما للإضافة والآخر للخصم Sub TransferMatchingData() Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 2).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value vOut = .Offset(, 1).Resize(, 2).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 2) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vOut(I, 1) = .Item(vData(I, 1)) vOut(I, 2) = vOut(I, 2) + vOut(I, 1) Else vOut(I, 1) = "" End If Next I End With .Offset(, 1).Resize(, 2).Value = vOut End With End Sub Sub TransferMatchingItems() Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long vItems = Sheet5.Range("C8", Sheet5.Cells(Rows.Count, "C").End(xlUp)).Resize(, 7).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value vOut = .Offset(, 2).Resize(, 2).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 7) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vOut(I, 2) = .Item(vData(I, 1)) vOut(I, 1) = vOut(I, 1) - vOut(I, 2) Else vOut(I, 1) = "" End If Next I End With .Offset(, 2).Resize(, 2).Value = vOut End With End Sub تقبل وافر تقديري واحترامي

أخي العزيز سعيد قم بوضع الكود التالي بعد تعديل بسيط في موديول عادي Sub TransferMatchingData() Dim vItems As Variant, vData As Variant, I As Long vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 2).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 2) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vData(I, 1) = .Item(vData(I, 1)) Else vData(I, 1) = "" End If Next I End With .Offset(, 1).Value = vData End With End Sub Sub TransferMatchingItems() Dim vItems As Variant, vData As Variant, I As Long vItems = Sheet5.Range("C8", Sheet5.Cells(Rows.Count, "C").End(xlUp)).Resize(, 7).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 7) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vData(I, 1) = .Item(vData(I, 1)) Else vData(I, 1) = "" End If Next I End With .Offset(, 3).Value = vData End With End Sub قم بحذف الكود الموجود في موديول والذي يشير إلى Workbook_Change ويحبذ ألا تستخدم التغير في حدث ورقة العمل بالمصنف ********************************************************************************************* وأخيراً قم بوضع الكود التالي في حدث ورقة العمل المسماة "الرئيسية" Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 5 And Target.Row > 7 Then Application.ScreenUpdating = False Application.EnableEvents = False If Target.Value > Target.Offset(, -1) Or IsEmpty(Target.Offset(, -1)) Then MsgBox "الكمية المباعة أكبر من الكمية الموجودة أو لا يوجد كميات موجودة على الإطلاق", vbExclamation Target.ClearContents: Target.Activate Else Target.Offset(, -1).Value = Target.Offset(, -1).Value - Target.Value Target.ClearContents End If Application.EnableEvents = True Application.ScreenUpdating = True ElseIf Target.Column = 3 And Target.Row > 7 Then Application.ScreenUpdating = False Application.EnableEvents = False Target.Offset(, 1).Value = Target.Offset(, 1).Value + Target.Value Target.ClearContents Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub تقبل تحياتي إضافة وخصم الكميات الواردة والصادرة مع كل إدخال جديد.rar

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

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

أخي العزيز آل سراج هكذا يكون الشرح ..رغم البساطة الشديدة في الشرح ولكنه يؤدي الغرض ويوصل المطلوب بسهولة أرجو أن يتخذ الأعضاء من المشاركة السابقة نموذج لشرح المطلوب فقد تم توضيح المطلوب في سطرين بدلاً من التطويل في الموضوع بدون داعي وبدون فائدة تذكر إليك الكود التالي وإن شاء الله يفي بالغرض Sub TransferUsingRangesArray() Dim myValues With Sheet2 myValues = Array(.Range("I10"), .Range("H8"), .Range("G9"), .Range("G10"), .Range("J18")) End With With Sheet3 .Range("G" & .Cells(1000, "G").End(xlUp).Row + 1).Resize(1, 5).Value = myValues End With End Sub

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

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

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

أخي الفاضل جرب التعديل التالي وإن شاء الله يحل المشكلة وسأخبرك بالتعديل بعد التجربة Sub AL_KHALEDI() Dim Arr As Variant Dim Rn As Range Dim C As Range Dim Lr As Long Dim T1 As String Dim T2 As String Dim Str As String Dim S As Variant Dim R As Integer Dim A As Integer Set Rn = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp)) Lr = Rn.Rows.Count ReDim Arr(Lr - 1) For Each C In Rn.Cells T1 = "" T2 = "" Str = Application.Trim(C) For R = 1 To Len(Str) T1 = Mid(Str, R, 1) S = Application.Search(T1, "أبجدهوزحطيكلمنسعفصقرشتثخذضظغ", 1) If Not IsError(S) Then T1 = Mid("أبتثجحخدذرزسشصضطظعغفقكلمنهوي", S, 1) T2 = T2 & T1 Next R Arr(A) = T2 A = A + 1 Next C Range("K2").Resize(Lr).Value = WorksheetFunction.Transpose(Arr) Range("B2:K2").Resize(Lr).Sort Range("K2"), xlAscending Range("K2").Resize(Lr).ClearContents Set Rn = Nothing Erase Arr End Sub تقبل تحياتي

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

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

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

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

أخي الكريم المسلم العربي يرجى تغيير اسم الظهور ليعبر عن شخصكم الكريم (وهذا ليس أول نداء لك) جرب الكود التالي عله يكون المطلوب Private Sub ComboBox1_Change() Dim Ws As Worksheet Application.ScreenUpdating = False On Error Resume Next For Each Ws In Worksheets If Ws.Name <> "Info" Then If ComboBox1.Value = Ws.Range("A1").Value Then Ws.Activate: Exit For Else Sheets("Info").Activate End If Next Ws Application.ScreenUpdating = True End Sub وإن لم يكن المطلوب فيرجى التوضيح أكثر تقبل تحياتي

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