الحضرمي2017

جزاك الله خير الجزاء والله شاكر لك ولا يحرمك ربي أجر هذه الايام وحفظك الله وبارك الله لك في علمك

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

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

جزاك الله خير الجزاء والعفو منك يالغالي

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

آسف أخي الحبيب سليم والله ماكان قصدي الإساءة إليك بشيء أو أخذ ما ليس لي يمكن والله وقسما بالله عفوية والكل يعرفني هنا لذا ارجوا مسامحتي ومعذرتي على التطاول على حقوقكم وأسأل الله أن يعفو عني هذه الزلة أخي الحبيب لو تكرمت أبغا الترتيب يطلع بالشكل التالي 99 الأول 98 الثاني مكرر 98 الثاني مكرر 97 الثالث 94 الرابع 92 السادس 93 الخامس يكون بدون مكرر 1 أو مكرر 2 واكرر اعتذاري مرة أخرى والله ويعلم الله أن لم اقصد الاساءة لأنها ليست من طباعي الله يحفظك ويبارك في علمك ويزيدك من فضله

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

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

تفضل أخي الحبيب المصنف100.xlsm

يمكن أحد الاخوة يفيدك والله والله لا اعلم انا والله مثلك متعلم

تسطيع ذلك أخي الحبيب هذا الملف الخامس معدل.xlsm

المشكلة في الملف السابق كانت هنا فقط عدلت الرقم بدل 11 الى 1 فضبطت ولله الحمد والمنة

تم التعديل الخامس.xlsm

الاشكالية الوحيدة الان والتي آمل أن أجد من يسعفني في حلها الكود اللي في المشاركة سليم ويعمل تمام التمام الاشكالية في الاتي : 1- ان الملف الناتج يكون في الغالب بجانب الملف اللي اعمل به وهذا لا اريدة اريدة دائما وابدا ينشأ لي المجلد على سطح المكتب 2- ليس بتلك الاهمية وهو هل بامكاني أن أحدد النطاق الذي سيتم حفظه في الملف الجديد اذا أمكن

جزاك الله خير أخي الحبيب طارق نادر تم حل الاشكالية ووالله مدري هل طريقة صحيحة أم لا المهم أني حذفت بعض الكلمات وضبط معي الأمر ولا أدري كيف Sub Macro1() Dim strFilename, strDirname, strPathname, strDefpath As String On Error Resume Next ' If directory exist goto next line strDirname = Range("a1").Value ' New directory name strFilename = Range("a2").Value 'New file name strDefpath = Application.ActiveWorkbook.Path 'Default path name If IsEmpty(strDirname) Then Exit Sub If IsEmpty(strFilename) Then Exit Sub MkDir strDefpath & "\" & strDirname strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string ActiveWorkbook.SaveCopyAs Filename:=strPathname & ".xlsm" End Sub الكود بعد التعديل عليه صار يسوي لي ملجد اسمه من البيانات الموجودة في A1 ويضع ملف بداخلة بصيغة xlsm اسمه وفق البيانات الموجودة في A2 وهو ما اردته بالضبط فالله الحمد والمنة

فيه اشكالية بسيطة ارجو من احد الاخوة أن يفيدني بها وهي أني استبدال ActiveWorkbook.SaveAs ب ActiveWorkbook.SavecopyAs حتى يتم حفظ الملف باسم مختلف في كل مرة لأن المشكلة انني لما اعمل حفظ في المرة الأولى واسوي حفظ للمرة الثانية ينشئ المجلد داخل الملجد الاول وهكذ مجلد داخل مجلد

أخيرا ولله الحمد والمنة من قبل ومن بعد وجدت الكود المناسب وهو ما طلبته بالضبط وآمل أن ينتفع به الإخوة Sub Macro1() Dim strFilename, strDirname, strPathname, strDefpath As String On Error Resume Next ' If directory exist goto next line strDirname = Range("D81").Value ' New directory name strFilename = Range("D8").Value 'New file name strDefpath = Application.ActiveWorkbook.Path 'Default path name If IsEmpty(strDirname) Then Exit Sub If IsEmpty(strFilename) Then Exit Sub MkDir strDefpath & "\" & strDirname strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _ FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False End Sub

لقيت هذا الكود لا نشاء مجلد Sub MakeMyFolder() انشاء المجلد ' Dim fdObj As Object Application.ScreenUpdating = False Set fdObj = CreateObject("Scripting.FileSystemObject") If fdObj.FolderExists("C:\Users\ALHDRAMI\Desktop\as") Then MsgBox "Found it.", vbInformation, "Kutools for Excel" Else fdObj.CreateFolder ("C:\Users\ALHDRAMI\Desktop\as") MsgBox "It has been created.", vbInformation, "Kutools for Excel" End If Application.ScreenUpdating = True End Sub وهذا كود ثاني لانشاء مجلد وحفظ شيت معين بداخله Sub Mfolder_Export_SheetPDF() 'انشاء ملف Dim Name As String, Path As String Path = "c:\Snow Eagle" & Format(Now, "dd-mm-yyyy hh.mm.ss") MkDir Path Name = Sheets("Sheet3").Name Sheets("Sheet3").ExportAsFixedFormat xlTypePDF, Path & "\" & Name End Sub مشكلة أني لم استطع توظيف اي منهن في الفكرة التي في ذهني فهل احد يتفضل بالمساعدة وجزاكم الله خير الجزاء

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

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

حاولت وحاولت لكن دون جدوى لو تكرمتم اخوتي المساعدة

ألا هل من مساعدة لو تكرمتم اخوتي

السلام عليكم ورحمة الله وبركاته حياكم الله اخوتي الاحبة اريد ان اعرف اين اضيف هذا الكود في الاكسل هل هو في موديل module جديد ام في ورقة العمل ام اين بالضبط ثم بعد الاضافة ماهي الصيغة التي اضيفها في الخلية واذا تكرم احد الاخوة وجهز الملف بالكود اكون شاكر له وجزاه الله خير الجزاء الكود هو Public Ones(0 To 12) As String Public Twos(2 To 9) As String Public Threes(1 To 2) As String Public Fours(1 To 3) As String Public Sevens(1 To 3) As String Public Tens(1 To 2) As String Public Prepositions() As String Public Decimals(1 To 3) As String Public Function Main(الرقم_رقماً) Dim lRange As Long Dim lPosDecimal As Long Dim sWhole As String, sDecimal As String On Error Resume Next LoadArrays 'الرقم_رقماً = Forms![نموذج1]![نص84] lRange = Len(الرقم_رقماً) If lRange <> 0 Then lPosDecimal = InStr(1, الرقم_رقماً, ".", vbTextCompare) If lPosDecimal > 0 Then sWhole = Mid(الرقم_رقماً, 1, lPosDecimal - 1) sDecimal = Mid(الرقم_رقماً, lPosDecimal + 1) sWhole = sLeftRemove(sWhole, "0") sDecimal = sRightRemove(sDecimal, "0") If InStr(sDecimal, ".") Then sDecimal = sFindReplace(sDecimal, ".", "") If InStr(sWhole, ",") Then sWhole = sFindReplace(sWhole, ",", "") If InStr(sWhole, "،") Then sWhole = sFindReplace(sWhole, "،", "") If InStr(sDecimal, ",") Then sWhole = sFindReplace(sDecimal, ",", "") If InStr(sDecimal, "،") Then sWhole = sFindReplace(sDecimal, "،", "") If Len(sDecimal) > 9 And Len(sWhole) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "whole and decimal portion of the number", vbOKOnly, "Number to Text" Exit Function End If If Len(sWhole) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "whole portion of the number", vbOKOnly, "Number to Text" Exit Function End If If Len(sDecimal) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "decimal portion of the number", vbOKOnly, "Number to Text" Exit Function End If If sDecimal <> "" Then If CLng(sDecimal) <> 0 Then If sWhole <> "" Then If CLng(sWhole) <> 0 Then الرقم_كتابة = sNum2Text(CLng(sWhole)) & " " & Prepositions(1) & _ sDec2Text(sDecimal) Else الرقم_كتابة = sDec2Text(sDecimal) End If Else الرقم_كتابة = sDec2Text(sDecimal) End If Else الرقم_كتابة = sNum2Text(CLng(sWhole)) End If Else الرقم_كتابة = sNum2Text(CLng(sWhole)) End If Else 'Only whole number If InStr(sWhole, ",") Then sWhole = sFindReplace(sWhole, ",", "") If InStr(sWhole, "،") Then sWhole = sFindReplace(sWhole, "،", "") sWhole = الرقم_رقماً sWhole = sLeftRemove(sWhole, "0") If Len(sWhole) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "whole portion of the number", vbOKOnly, "Number to Text" Exit Function End If الرقم_كتابة = sNum2Text(CLng(sWhole)) End If End If ' MsgBox الرقم_كتابة Main = الرقم_كتابة End Function Public Function sNum2Text(lNum As Long) As String Dim sNum As String 'The number as string to pass as a vlaue name in the INI file Dim I As Integer 'Loop counter to loop through all of the digits Dim iUpperBound As Integer 'Represents # of digits in each group of 3 significant bits On Error Resume Next sNum = Trim$(CStr(lNum)) 'Get rid of the zeros to the left If (lNum >= 0) And (lNum <= 12) Then '0 through 12 sNum2Text = Ones(lNum) ElseIf lNum Mod 10 = 0 And Len(sNum) = 2 Then '20,30,40,...,90 sNum2Text = Twos(CLng(Left(sNum, 1))) ElseIf lNum > 12 And lNum < 20 Then '13 to 19 sNum2Text = Ones(CLng(Right(sNum, 1))) & " " & Ones(10) ElseIf lNum Mod 10 > 0 And Len(sNum) = 2 Then '21,22,...29,31,32,33,...,99 sNum2Text = Ones(CLng(Right(sNum, 1))) & " " & Prepositions(1) & _ Twos(CLng(Left(sNum, 1))) ElseIf (lNum = 100) Or (lNum = 200) Then '100,200 sNum2Text = Threes(CLng(Left(sNum, 1))) ElseIf (lNum Mod 100) = 0 And Len(sNum) = 3 Then '300,400,500,...,900 sNum2Text = Ones(CLng(Left(sNum, 1))) & " " & Threes(1) ElseIf lNum Mod 100 > 0 And Len(sNum) = 3 Then '101,102,103,...,199,201,...999 If Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then sNum2Text = Ones(CLng(Left(sNum, 1))) & " " & Threes(1) Else sNum2Text = Threes(CLng(Left(sNum, 1))) End If If Right(sNum, 2) = "11" Or Right(sNum, 2) = "12" Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 2))) ElseIf Mid(sNum, 2, 1) <> "0" And Mid(sNum, 2, 1) <> "1" And Right(sNum, 1) <> 0 Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) & _ " " & Prepositions(1) & Twos(CLng(Mid(sNum, 2, 1))) ElseIf Mid(sNum, 2, 1) <> "0" And Mid(sNum, 2, 1) <> "1" And Right(sNum, 1) = 0 Then sNum2Text = sNum2Text & " " & Prepositions(1) & Twos(CLng(Mid(sNum, 2, 1))) ElseIf Mid(sNum, 2, 1) = "1" Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) & _ " " & Ones(10) ElseIf Mid(sNum, 2, 1) = "0" Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) Else 'Right(sNum, 2) = "00" sNum2Text = sNum2Text End If ElseIf Len(sNum) / 3 > 1 Then Do Until Len(sNum) = 3 If Len(sNum) Mod 3 <> 0 Then iUpperBound = Len(sNum) Mod 3 Else iUpperBound = 3 End If If (Len(sNum) / 3 > 2) And (Len(sNum) / 3 < 4) Then 'In the millions If Mid(sNum, 1, iUpperBound) = "000" Then Exit Do ElseIf (Len(sNum) Mod 3 = 1) And (Left(sNum, 1) = "1" Or Left(sNum, 1) = "2") Then sNum2Text = sNum2Text & Sevens(CLng(Left(sNum, 1))) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 1) And Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Sevens(3) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 2) And Left(sNum, 2) = "10" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Sevens(3) & " " & Prepositions(1) Else sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Sevens(1) & " " & Prepositions(1) End If ElseIf (Len(sNum) / 3 >= 1) And (Len(sNum) / 3 < 3) Then 'In the thousands If Mid(sNum, 1, iUpperBound) = "000" Then Exit Do ElseIf (Len(sNum) Mod 3 = 1) And (Left(sNum, 1) = "1" Or Left(sNum, 1) = "2") Then sNum2Text = sNum2Text & Fours(CLng(Left(sNum, 1))) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 1) And Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Fours(3) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 2) And Left(sNum, 2) = "10" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Fours(3) & " " & Prepositions(1) Else sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Fours(1) & " " & Prepositions(1) End If End If sNum = Mid(sNum, iUpperBound + 1) lNum = CLng(sNum) 'Make sure the least significant 6 digits are not zero If sNum = String(Len(sNum), "0") Then sNum2Text = Left(sNum2Text, Len(sNum2Text) - 1) Exit Function End If Loop 'Make sure the least significant 3 digits are not zero If sNum <> String(Len(sNum), "0") Then sNum2Text = sNum2Text & sNum2Text(lNum) Else 'get ride of the AND sNum2Text = Left(sNum2Text, Len(sNum2Text) - 1) End If End If End Function Public Function sDec2Text(sNum As String) As String Dim lLen As Long On Error Resume Next Do While Right(sNum, 1) = "0" sNum = Left(sNum, Len(Trim(sNum)) - 1) Loop lLen = Len(Trim(sNum)) If lLen = 0 Then sDec2Text = "" Exit Function ElseIf lLen = 1 Then Select Case sNum Case "0" sDec2Text = "" Case "1" sDec2Text = Decimals(1) Case "2" sDec2Text = Decimals(2) Case Else sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Decimals(3) End Select ElseIf lLen = 2 Then sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(2) & _ sNum2Text("1" & String(lLen, "0")) ElseIf lLen = 9 Then sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(3) & _ Tens(1) Else sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(3) & _ sNum2Text("1" & String(lLen, "0")) End If End Function Public Sub LoadArrays() 'Load the arrays with values 'Ones Ones(0) = "صفر" Ones(1) = "واحد" Ones(2) = "اثنان" Ones(3) = "ثلاثة" Ones(4) = "أربعة" Ones(5) = "خمسة" Ones(6) = "ستة" Ones(7) = "سبعة" Ones(8) = "ثمانية" Ones(9) = "تسعة" Ones(10) = "عشرة" Ones(11) = "أحد عشرة" Ones(12) = "اثنا عشرة" 'Twos Twos(2) = "عشرون" Twos(3) = "ثلاثون" Twos(4) = "أربعون" Twos(5) = "خمسون" Twos(6) = "ستون" Twos(7) = "سبعون" Twos(8) = "ثمانون" Twos(9) = "تسعون" 'Threes Threes(1) = "مائة" Threes(2) = "مائتان" 'Fours Fours(1) = "ألف" Fours(2) = "ألفان" Fours(3) = "آلاف" 'Sevens Sevens(1) = "مليون" Sevens(2) = "مليونان" Sevens(3) = "ملايين" 'Tens Tens(1) = "بليون" Tens(2) = "بلايين" 'Prepositions ReDim Prepositions(1 To 3) Prepositions(1) = "و" Prepositions(2) = "بال" Prepositions(3) = "من ال" 'Decimals Decimals(1) = "عشر" Decimals(2) = "عشران" Decimals(3) = "أعشار" End Sub Public Function sFindReplace(sString As String, sOld As String, sNew As String) As String On Error GoTo sFindReplace_Hndlr Dim I As Integer sFindReplace = sString I = 1 'Loop through all the characters of a string For j = 1 To Len(sString) If InStr(sOld, Mid(sFindReplace, I, 1)) Then sFindReplace = Mid(sFindReplace, 1, I - 1) & sNew & Mid(sFindReplace, I + 1) I = I - 1 End If I = I + 1 Next j Exit Function sFindReplace_Hndlr: Debug.Print "RTE Desc: " & Err.Description Debug.Print "RTE Num: " & Err.Number sFindReplace = sString Exit Function End Function Public Function sLeftRemove(str1 As String, str2 As String) As String On Error Resume Next If str1 = "0" And str2 = "0" Then sLeftRemove = str1 Exit Function End If Do While Left(str1, 1) = str2 str1 = Mid(str1, 2) Loop If str1 = "" Then str1 = "0" sLeftRemove = str1 End Function Public Function sRightRemove(str1 As String, str2 As String) As String On Error Resume Next If str1 = "0" And str2 = "0" Then sRightRemove = str1 Exit Function End If Do While Right(str1, 1) = str2 str1 = Mid(str1, 1, Len(str1) - 1) Loop If str1 = "" Then str1 = "0" sRightRemove = str1 End Function 'وفي النموذج في حدث عند الخروج من حقل الرقم ضع : 'Private Sub حقل_الرقم_Exit(Cancel As Integer) 'If Not IsNull(Me!حقل_الرقم) Then 'الرقم_رقما 'ً = حقل_الرقم 'Call Main ' '[حقل'_الكتابة] = الرقم_كتابة 'End If 'End Sub

الباسووورد هو easy