Ali Mohamed Ali

يمكنك اخذ نفس هذه المعادلة والتعديل عليها كما تشاء .

الأمر بسيط جدا اولا عليك بفتح مديول جديد ووضع هذا الكود به كما هو بالملف المرسل لك سابقا Option Explicit 'Main Function Function SpellNumber(ByVal MyNumber) Dim Euro, Cent, Temp Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Mille " Place(3) = " Million " Place(4) = " Milliard " Place(5) = " Billion " ' String representation of amount. MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none. DecimalPlace = InStr(MyNumber, ".") ' Convert Fils and set MyNumber to Dinar amount. If DecimalPlace > 0 Then Cent = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _ "00", 2)) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" Temp = GetHundreds(Right(MyNumber, 3)) If Temp <> "" Then Euro = Temp & Place(Count) & Euro If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Euro Case "" Euro = "No Euro" Case "Un" Euro = "Un Euro" Case Else Euro = Euro & "Euro" End Select Select Case Cent Case "" Cent = " et Non Cent" Case "Un" Cent = " et Un Cent" Case Else Cent = " et " & Cent & " Cent" End Select SpellNumber = Euro & Cent End Function ' Converts a number from 100-999 into text Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) ' Convert the hundreds place. If Mid(MyNumber, 1, 1) <> "0" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Cent " End If ' Convert the tens and ones place. If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & GetTens(Mid(MyNumber, 2)) Else Result = Result & GetDigit(Mid(MyNumber, 3)) End If GetHundreds = Result End Function ' Converts a number from 10 to 99 into text. Function GetTens(TensText) Dim Result As String Result = "" ' Null out the temporary function value. If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19... Select Case Val(TensText) Case 10: Result = "Dix" Case 11: Result = "Onze" Case 12: Result = "Douze" Case 13: Result = "Treize" Case 14: Result = "Quatorze" Case 15: Result = "Quinze" Case 16: Result = "Seize" Case 17: Result = "Dix-sept" Case 18: Result = "Dix-huit" Case 19: Result = "Dix-neuf" Case Else End Select Else ' If value between 20-99... Select Case Val(Left(TensText, 1)) Case 2: Result = "Vingt " Case 3: Result = "Trente " Case 4: Result = "Quarante " Case 5: Result = "Cinquante " Case 6: Result = "Soixante " Case 7: Result = "Soixante-dix " Case 8: Result = "Quatre-vingts " Case 9: Result = "Quatre vingt dix " Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) ' Retrieve ones place. End If GetTens = Result End Function ' Converts a number from 1 to 9 into text. Function GetDigit(Digit) Select Case Val(Digit) Case 1: GetDigit = "Un" Case 2: GetDigit = "deux" Case 3: GetDigit = "Trois" Case 4: GetDigit = "Quatre" Case 5: GetDigit = "Cinq" Case 6: GetDigit = "Six" Case 7: GetDigit = "Sept" Case 8: GetDigit = "Huit" Case 9: GetDigit = "Neuf" Case Else: GetDigit = "" End Select End Function ثم بعد ذلك فى شيت الإكسيل ,مثلا اذا كان الرقم المراد تحويله الى حروف باللغة الفرنسية موجود بالخلية A2 -فعليك كتابة هذه المعادلة فى المكان الذى تريد اظهار الحروف به ="Seulement"&SpellNumber(A2) بارك الله فيك اتمنى ان تكون الصورة واضحة لك الأن

اهلا بك اخى الكريم فى المنتدى تفضل جمع وقسمة.xlsx

تفضل تفقيط فرنسى.xlsm

اهلا بك اخى الكريم فى المنتدى تفضل Book2.xlsx

كما ترى اخى الكريم فالمشكلة بالفعل من عندك فالملف والكود يعملان معى بكفاءة وتتم الطباعة على اكمل وجه عليك التأكد من اسماء الصفحات كما بالكود

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

هل امتداد الملف xlsm

المشكلة من عندك انت لابد من تفعيل وحدات الماكرو كما بالصورة

وعليكم السلام مراحل التقييم.xlsm

اخى الكريم المشكلة من عندك عليك بتفعيل وحدات الماكرو لديك لابد ان تكون وحدات الماكرو لديك مفعلة كما بالصورة

فقط عليك وضع هذا الكود فى موديول عادى Public CntTme As Double Sub StartClock() ActiveSheet.Range("N1").Value = Now() CntTme = Now + TimeSerial(0, 0, 1) Application.OnTime CntTme, "'" & ThisWorkbook.Name & "'!StartClock", , True End Sub ثم بعد ذلك عليك بوضع هذا الكود فى حدث This Workbook Private Sub Workbook_Open() StartClock End Sub لابد ان يكون امتداد الملف Xlsm

تفضل هذا كود لحفظ الملف بصيغة XLSM ويكون اسم الملف موجود بالخليتين M1 & M2 Sub SaveAs() ThisWorkbook.Save 'save current workbook in current name With Application.FileDialog(msoFileDialogSaveAs) .AllowMultiSelect = False .FilterIndex = 2 .InitialFileName = Range("M2").Text & Range("M1").Text 'specify folder - can also include default filename in here too If .Show Then ActiveWorkbook.SaveAs Filename:=.SelectedItems(1), _ FileFormat:=xlOpenXMLWorkbookMacroEnabled End If End With End Sub وهذا كود لحفظ الملف بصيغة PDF Sub PDFActiveSheet() Dim wsA As Worksheet Dim wbA As Workbook Dim strTime As String Dim strName As String Dim strPath As String Dim strFile As String Dim strPathFile As String Dim myFile As Variant On Error GoTo errHandler Set wbA = ActiveWorkbook Set wsA = ActiveSheet strTime = Format(Now(), "yyyymmdd\_hhmm") strPath = wbA.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" strName = Replace(wsA.Name, " ", "") strName = Replace(strName, ".", "_") strFile = strName & "_" & strTime & ".pdf" strPathFile = strPath & strFile myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="PDF Files (*.pdf), *.pdf", _ Title:="Select Folder and FileName to save") If myFile <> "False" Then wsA.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=myFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False MsgBox "PDF file has been created: " _ & vbCrLf _ & myFile End If exitHandler: Exit Sub errHandler: MsgBox "Could not create PDF file" Resume exitHandler End Sub

اجعل نوع الخط Wingdings 2

تفضل الكود ومعه ملف Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("c8:AH397")) Is Nothing Then If Target.Value = "" Then Cancel = True Target.Value = "P" Range("c8:AH397").Font.Name = "Wingdings 2" Else Cancel = True Target.Value = "" End If End If End Sub ادراج علامة صح.xlsm

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

لا يمكن هذا فلا يمكن ادخال البيانات فى الإكسيل بالصوت الا بمقابل فهذه خدمة مدفوعة الأجر وليست مجانية https://khamsat.com/technology/data-entry/490222-تفريغ-البيانات-إلى-ملفات-الاكسل واتمنى هذا الفيديو يفيدك فى ادخال البيانات https://www.youtube.com/watch?v=kcrOID5bJsg

وعليكم السلام تفضل تسلسل.xls

يمكنك الإستعانة بهذه الفيديوهات https://www.youtube.com/watch?v=w_lH3sZyUDY https://www.youtube.com/watch?v=x-w_Z6UHCnQ https://www.youtube.com/watch?v=pGVzzvrR2L4 https://www.youtube.com/watch?v=ErocP5o0ARM وهذان ملفان وورد واكسيل تم نقل بيانات شيت الإكسيل الى الوورد كما ترى excel to word.xlsm ser.docx

تفضل اخى الكريم نفس ملف استاذنا الكريم سليم وتم تعديل المطلوب protect first column.xlsm

تفضل دفتر التنقيط.xlsm

كيف نقوم بمساعدتك على ملف محمى بكلمة سر

ولكى يعمل هذا الكود معك فى كل صفحة جديدة تفتحها داخل الملف لابد من وضع هذا الكود فى حدث This WorkBook Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Call Test End Sub كود ضرب.xlsm

تفضل 2أوفيسنا.xlsx

طبعا يمكن العمل فى كل صفحة ولكن لابد من ربطه بزر Sub Test() 'بداية الكود Dim LR As Long 'تحديد LR كمتغير الى اخر سطر به بيانات LR = Range("C" & Rows.Count).End(xlUp).Row Range("E1:E" & LR) = Evaluate("C1:C" & LR & "*D1:D" & LR) 'حاصل ضرب العمود C مع العمود D 'واخراج الناتج فى العمود E End Sub 'نهاية الكود