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

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

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

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

أخي الكريم كريم أين المرفق؟ يرجى إرفاق بعض النتائج مع الملف المرفق لتتضح المسألة أكثر

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

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

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

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

نورت المنتدى أخي الكريم وسام وأهلا بك بين إخوانك وأحبابك في الله وفي انتظار مساهماتك .... يلا ورينا الهمة

تم التعديل في المشاركة الأولى كما أردت وأعتذر عن عدم الإطالة .. تقبل تحياتي

جرب التالي .. لاحظ أن الموضوع الذي اقتبست منه الكود فيه رابط لحلقات افتح الباب وفيه تفصيل أكثر لو احببت الإطلاع عليه Sub Sort_Female() Dim LR As Long LR = Range("M" & Rows.Count).End(xlUp).Row Range("K7:R" & LR).Sort Key1:=Range("R7:R" & LR), Order1:=xlAscending, Key2:=Range("M7:M" & LR), Order2:=xlAscending, Header:=xlNo End Sub Sub Sort_Male() Dim LR As Long LR = Range("M" & Rows.Count).End(xlUp).Row Range("K7:R" & LR).Sort Key1:=Range("R7:R" & LR), Order1:=xlDescending, Key2:=Range("M7:M" & LR), Order2:=xlAscending, Header:=xlNo End Sub يوجد معادلات في النطاق وبعد تنفيذ الأكواد تعطي خطأ VALUE لا أعلم السبب في ذلك ..يرجى مراجعة الملف بشكل جيد والوقت لا يسعني الآن للإطلاع على الملف عموماً أترك الأمر لإخواني بالمنتدى ليدرسوا المشكلة بشكل أعمق تقبل تحياتي

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

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

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

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

أخي الكريم طارق أين الملف المرفق وأين الكود الذي تتحدث عنه وأين أنت الآن ؟؟

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

لابد من صياغة الطلب بشكل جديد وبمنطق صحيح لكي تجد الحل المناسب ...

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

أخي الكريم زهير جرب الكود التالي عله يفي بالغرض إن شاء الله Sub Create_VCF() Dim FileNum As Integer Dim iRow As Double Dim OutFilePath As String Dim fName As String Dim lName As String Dim PhNum As String iRow = 2 FileNum = FreeFile OutFilePath = ThisWorkbook.Path & "\Output.VCF" Open OutFilePath For Output As FileNum While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> "" fName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) lName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2)) PhNum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3)) Print #FileNum, "BEGIN:VCARD" Print #FileNum, "VERSION:3.0" Print #FileNum, "N:" & fName & ";" & lName & ";;;" Print #FileNum, "FN:" & fName & " " & lName Print #FileNum, "TEL;TYPE=CELL;TYPE=PREF:" & PhNum Print #FileNum, "END:VCARD" iRow = iRow + 1 Wend Close #FileNum MsgBox "Contacts Converted to Saved To: " & OutFilePath End Sub تقبل تحياتي Convert Excel Contacts To VCF YasserKhalil Officena.rar

أخي الحبيب سليم بارك الله فيك وجزاك الله كل خير بينما كنت تقدم الحل لأخونا محمد السباعي كنت منهمك في الكود التالي (الذي تعدى معي حد الجنون ..!! أكثر من ساعة ونصف وربما ساعتين في هذا الكود) هو كود مجنون بحق .. حاولت فيه بقدر المستطاع أن أجعله كون مرن يصلح لأي موضوع شبيه بهذا الموضوع (خصوصاً أن هذا الموضوع يتكرر في كثير من الأحيان) وهو أن يكون هناك ورقة عمل رئيسية بها عمودوالمطلوب ترحيل القيم في هذا العمود إلى الورقة المناسبة ، وأضفنا إليه من قبل إمكانية إنشاء ورقة عمل إذا لم تكن موجودة .. الكود المجنون من العيار الثقيل وأرجو أن يبدي الأعضاء أي ملاحظات عليه لتطويره بحيث يصلح لهذه المشكلة أياً كان شكلها وحجمها وأبعادها ... الكود بالشكل التالي Sub Transfer_Data_Using_Filter_By_List() 'Author : YasserKhalil 'Release : 01 - 09 - 2016 '------------------------ Dim dictPerson As Object, dictSheet As Object, mtx(), isFound As Boolean Dim I As Long, v1 As Variant, v2 As Variant, arr As Variant, arrCol As Variant Dim rng As Range, arrHeader As Variant Dim cnt As Integer, counter As Integer Dim Rc As Long, Gc As Long, Bc As Long '=========================================================================================== 'Column Number To Be Filtered Const iCol As Integer = 5 'Sheet Name (The Source Sheet) Const sSheet As String = "DATA" 'Data Range Including Header Set rng = Sheets(sSheet).Range("A5:E" & Sheets(sSheet).Cells(Rows.Count, iCol).End(xlUp).Row) 'Row Number For Destination Sheets (5 = Row 5) Const destRow As Integer = 5 'Column Number For Destination Sheets (1 = Column A) Const destCol As Integer = 1 'Column Widths For Output Sheets arr = Array(14, 50, 15, 14) 'Columns Order To Be Copied. So Column 4 In Data Sheet To Be Copied To Column 1 To Destination Sheet arrCol = Array(4, 3, 1, 2) 'Columns Order To Be Copied. So Column 4 In Data Sheet To Be Copied To Column 1 To Destination Sheet arrHeader = Array("القيمة", "البيان", "التوجيه المحاسبي", "التاريخ") '=========================================================================================== Application.ScreenUpdating = False mtx = rng.Value Set dictPerson = CreateObject("Scripting.Dictionary") For I = 2 To UBound(mtx, 1) If Not dictPerson.Exists(mtx(I, iCol)) Then dictPerson.Add mtx(I, iCol), mtx(I, iCol) Next I Set dictSheet = CreateObject("Scripting.Dictionary") For I = 1 To Worksheets.Count If Not dictSheet.Exists(Worksheets(I).Name) Then dictSheet.Add Worksheets(I).Name, Worksheets(I).Name Next I dictSheet.Remove (sSheet) For Each v1 In dictPerson isFound = False For Each v2 In dictSheet If v1 = v2 Then isFound = True Exit For End If Next v2 If Not isFound Then If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then Worksheets.Add After:=Sheets(sSheet) ActiveSheet.Name = v1 ActiveSheet.DisplayRightToLeft = True Else dictPerson.Remove v1 End If End If Next v1 For Each v1 In dictPerson Sheets(v1).Cells.Clear rng.AutoFilter Field:=iCol, Criteria1:=v1 With rng.Offset(1) For counter = LBound(arrCol) To UBound(arrCol) .Columns(arrCol(counter)).SpecialCells(xlCellTypeVisible).Copy Sheets(v1).Cells(destRow + 1, destCol + counter).PasteSpecial xlPasteValues Sheets(v1).Columns(destCol + counter).NumberFormat = .Columns(arrCol(counter)).NumberFormat Next counter Sheets(v1).Cells(destRow, destCol).Resize(1, UBound(arrHeader) + 1).Value = arrHeader End With With rng(1, 1) Rc = .Interior.Color Mod 256 Gc = Int(.Interior.Color / 256) Mod 256 Bc = Int(Int(.Interior.Color / 256) / 256) Sheets(v1).Cells(destRow, destCol).Resize(1, UBound(arrHeader) + 1).Interior.Color = RGB(Rc, Gc, Bc) End With With Sheets(v1) With .Cells .ReadingOrder = xlRTL .Font.Name = "Arial" .Font.Size = 11 .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .RowHeight = 19 .ColumnWidth = 9 End With With .Cells(destRow - 1, destCol) .Offset(1).CurrentRegion.Borders.Value = 1 .Value = v1 .Resize(1, UBound(arrHeader) + 1).Interior.Color = vbYellow .Resize(1, UBound(arrHeader) + 1).HorizontalAlignment = xlCenterAcrossSelection End With With .Rows(destRow - 1).Resize(2) .RowHeight = 25 .Font.Bold = True .Font.Size = 13 End With For cnt = LBound(arr) To UBound(arr) .Columns(destCol + cnt).ColumnWidth = arr(cnt) Next cnt Application.Goto .Range("A1") End With Next v1 Application.Goto Sheets(sSheet).Range("A1") rng.AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub فمت بوضع التعليقات باللغة الإنجليزية (معلش تعود مش أكتر) سأقوم بشرحها لمن يهمه الأمر أول سطر في التعليق يتعلق برقم العمود الذي يحتوي على القيم التي سيتم فلترتها السطر التالي يكتب اسم ورقة العمل التي تحتوي على البيانات (الورقة الرئيسية) السطر التالي نطاق البيانات المراد العمل عليها السطر التالي رقم الصف المراد وضع البيانات فيه السطر التالي رقم العمود المراد وضع البيانات فيه .. مثال لو أردنا وضع البيانات في الخلية H3 هذا يعني أن رقم الصف هو 3 ورقم العمود هو 8 السطر التالي عرض الأعمدة في المخرجات ..بما أننا تعاملنا في المخرجات مع 4 أعمدة فيكتب 4 أرقام ..يمكنك ببساطة زيادة أو نقصان العدد السطر التالي ترتيب الأعمدة وهذا السطر مهم للغاية ..فقد لاحظت أن الترتيب ليس بالضبط كترتيب الورقة الرئيسية وهذا ما دفعني إلى كتابة الكود في الحقيقة .. المهم هنا الرقم 4 هو رابع عمود في ورقة البيانات ، والرقم 3 هو ثالث عمود في ورقة البيانات ، والرقم 1 أول عمود في ورقة البيانات ، والرقم 2 هو ثاني عمود في ورقة البيانات ، وسيتم ترحيلهم بنفس الترتيب إلى الأوراق الجديدة السطر التالي هو خاص بالعناوين التي ستوضع في الأوراق الأخرى والتي سيتم ترحيل البيانات إليها ، وقد قمت بذلك أيضاً لأنني لاحظت أن هناك تغيير في العناوين (العمود "مدين" يسمى في المخرجات باسم "القيمة") المهم الأربعة سطور الأخيرة يجب أن يكون كل منها محتوي على 4 عناصر حسب عدد الأعمدة المطلوبة في المخرجات أسأل الله العظيم أن يكون الكود مفيد لكم وأعتذر عن الإطالة .. ولكن كان لابد من التوضيح التام لما هو مهم في الكود لتتمكنوا من استخدامه بسهولة ويسر .. لتجربة الكود بشكل أعمق اختر في الخلية E12 ايصال تسوية ، وهي ورقة عمل غير موجودة لتشاهد ورقة العمل وهي تنشأ وتوضع فيها البيانات .. ولك الحرية في تلك النقطة (لك أن تنشيء ورقة العمل أو تلغي ... لابد أن يكون هناك مرونة) تقبلوا وافر تقديري واحترامي رابط الملف المرفق من هنا

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

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

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

الحمد لله أن تم المطلوب على خير .. أخي محمد الأفضل من قول "شكراً" قول "جزاك الله خيراً" فهي أفضل عندي وعند غيري تقبل تحياتي