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

أخي الكريم كيرلس بارك الله فيك على استجابتك لمطلبي بتغيير اسم الظهور باركك الرب المقدس .. تقبل تحياتي

بارك الله فيك أخي الحبيب سليم ولكن أعتقد أن الطلب مختلف عن الملف المرفق تماماً .. المطلوب كالتفقيط ولكن ليس كتفقيط العملات إنما الأرقام بهذا الشكل : الأول - الثاني - الثالث وهكذا أي بترتيب المراكز تقبل تحياتي

وجزيت خيراً بمثل ما دعوت أخي الحبيب أبو بسملة

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

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

أخي الكريم أحمد الأكواد لن تعمل في حدث فتح المصنف طالما أن الماكرو غير مفعل .. يمكنك استخدام ملف الريجستري المناسب لنسخة الأوفيس التي لديك لتفعيل الماكرو لديك .. من الملفات الموجودة في الملف المرفق جرب وأعملنا بالنتيجة تقبل تحياتي Enable Macros.rar

أخي الكريم طائع يمكنك استخدام دالة معرفة بهذا الشكل البسيط ..لقد قمت بإضافة من 1 إلى 30 (لعله يكون هناك طرق أفضل لتنفيذ المطلوب) Function SpellNumber(MyNumber) Select Case Val(MyNumber) Case 1: MyNumber = "الأول" Case 2: MyNumber = "الثاني" Case 3: MyNumber = "الثالث" Case 4: MyNumber = "الرابع" Case 5: MyNumber = "الخامس" Case 6: MyNumber = "السادس" Case 7: MyNumber = "السابع" Case 8: MyNumber = "الثامن" Case 9: MyNumber = "التاسع" Case 10: MyNumber = "العاشر" Case 11: MyNumber = "الحادي عشر" Case 12: MyNumber = "الثاني عشر" Case 13: MyNumber = "الثالث عشر" Case 14: MyNumber = "الرابع عشر" Case 15: MyNumber = "الخامس عشر" Case 16: MyNumber = "السادس عشر" Case 17: MyNumber = "السابع عشر" Case 18: MyNumber = "الثامن عشر" Case 19: MyNumber = "التاسع عشر" Case 20: MyNumber = "العشرون" Case 21: MyNumber = "الحادي والعشرون" Case 22: MyNumber = "الثاني والعشرون" Case 23: MyNumber = "الثالث والعشرون" Case 24: MyNumber = "الرابع والعشرون" Case 25: MyNumber = "الخامس والعشرون" Case 26: MyNumber = "السادس والعشرون" Case 27: MyNumber = "السابع والعشرون" Case 28: MyNumber = "الثامن والعشرون" Case 29: MyNumber = "التاسع والعشرون" Case 30: MyNumber = "الثلاثون" Case Else: MyNumber = "" End Select SpellNumber = MyNumber End Function يمكنك استخدام الدالة المعرفة بهذا الشكل =SpellNumber(A1) أرجو أن يفي بالغرض تقبل تحياتي

أخي الكريم علي الهتاري إليك الكود التالي فيه تنفيذ ما طلبت إن شاء الله Sub Test() Dim collWord As New Collection, collRow As New Collection, arrIn, arrOut, arrCalc(1 To 50000) As Long Dim I As Long, J As Long, P As Long, strKey1 As String, strKey2 As String, V1, V2 arrIn = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Formula arrOut = arrIn arrIn(1, 1) = "" For I = 1 To UBound(arrIn, 1) If Trim(arrIn(I, 1)) = "" Then For J = 0 To 2 arrIn(I + J, 1) = "" Next J I = I + 3 End If Next I With CreateObject("Vbscript.Regexp") .Global = True .IgnoreCase = True .Pattern = "[A-z0-9']+" For I = 1 To UBound(arrIn, 1) If Len(arrIn(I, 1)) Then strKey1 = Trim(CStr(I)) If InStrB(1, arrIn(I, 1), "<i>") Then arrIn(I, 1) = Replace(arrIn(I, 1), "<i>", Chr$(1)): arrOut(I, 1) = arrIn(I, 1) If InStrB(1, arrIn(I, 1), "</i>") Then arrIn(I, 1) = Replace(arrIn(I, 1), "</i>", Chr$(2)): arrOut(I, 1) = arrIn(I, 1) If .Test(arrIn(I, 1)) Then For Each V1 In .Execute(arrIn(I, 1)) strKey2 = CStr(V1) On Error Resume Next collRow.Add Key:=strKey1, Item:=Array(I, New Collection) collRow(strKey1)(1).Add Key:=strKey2, Item:=strKey2 collWord.Add Key:=strKey2, Item:=collWord.Count + 1 P = collWord(strKey2) arrCalc(P) = arrCalc(P) + 1 On Error GoTo 0 Next V1 End If End If Next I For Each V1 In collRow I = V1(0) For Each V2 In V1(1) J = arrCalc(collWord(V2)) .Pattern = "\b" & V2 & "\b" arrOut(I, 1) = .Replace(arrOut(I, 1), V2 & "*" & J & "*") Next V2 If InStrB(1, arrOut(I, 1), Chr$(1)) Then arrOut(I, 1) = Replace(arrOut(I, 1), Chr$(1), "<i>") If InStrB(1, arrOut(I, 1), Chr$(2)) Then arrOut(I, 1) = Replace(arrOut(I, 1), Chr$(2), "</i>") arrOut(I, 1) = "'" & arrOut(I, 1) Next V1 End With Range("B1").Resize(UBound(arrOut, 1)).Value = arrOut Range("B1").Value = "النتائج المطلوبة" End Sub وإليك الملف المرفق فيه تطبيق الكود تقبل تحياتي Movies Count Words.rar

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

جرب التعديل التالي (الاسم المستخدم في الكود هو الاسم البرمجي ورقة1) أما الاسم الظاهر في التبويب هو ورقة2 حاول تضبط المسميات بشكل صحيح Sub Test() Dim LR As Integer With ورقة1 LR = .Cells(27, 1).End(xlUp).Row + 1 .Range("A" & LR & ":F" & LR).Value = .Range("A3:F3").Value End With End Sub تقبل تحياتي

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

أخي الغالي محمد الريفي طالما أن الموضوع بهذا الشكل فلابد وأنك تحمل الجديد في الموضوع عموماً بالمعادلة التالية يمكن تحويل الرقم إلى تاريخ تسلسلي =DATEVALUE(MID(A1,1,4)&"/"&MID(A1,5,2)&"/"&MID(A1,7,2)) ومن ثم يمكن تنسيق مخصص للرقم التسلسلي ليصبح بهذا الشكل yyyy/mm/dd أو يمكن استخدام المعادلة التالية لتحويل الرقم التسلسلي لتاريخ =TEXT(LEFT(B1,5),"yyyy/mm/dd") تقبل وافر تقديري واحترامي

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

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

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

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

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

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

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

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

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

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

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

أخي الكريم محمد علي ضع الكود التالي في موديول عادي Sub ShowForm() UserForm1.Show End Sub Function LastRowPic(ColumnNumber As Long) As Long Dim Arr, Pic As Shape, I As Long ReDim Arr(1 To Columns.Count) For Each Pic In ActiveSheet.Shapes With Pic For I = .TopLeftCell.Column To .BottomRightCell.Column Arr(I) = Application.Max(.BottomRightCell.Row, IIf(Arr(I) = "", 0, Arr(I))) Next I End With Next Pic LastRowPic = Arr(ColumnNumber) End Function ثم قم بوضع الكود التالي في حدث الفورم #If VBA7 Then Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #Else Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If Private Const SW_HIDE As Long = 0 Private Const SW_SHOW As Long = 5 Private LastSelectedFilePath As String Private Sub CommandButton1_Click() Dim strFileName As String strFileName = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False) If strFileName = "False" Then MsgBox "File Not Selected!" Else Me.Image1.Picture = LoadPicture(strFileName) LastSelectedFilePath = strFileName Me.Repaint End If End Sub Private Sub CommandButton2_Click() Dim R As Range, LR As Long ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_HIDE If LastRowPic(22) = 0 Then LR = Cells(Rows.Count, "V").End(xlUp).Row + 1 Else LR = LastRowPic(22) Set R = Range("V" & LR) ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_SHOW With ActiveSheet.Pictures.Insert(LastSelectedFilePath) .ShapeRange.LockAspectRatio = msoFalse .Top = R.Top .Left = R.Left .Width = R.Width .Height = R.Height End With End Sub وإليك الملف المرفق فيه تطبيق للأكواد أرجو ان يكون المطلوب إن شاء الله Load Picture On UserForm Using Dialog & Insert Image To Worksheet YasserKhalil.rar

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