Ali Mohamed Ali

اى ملف تريد وليكن هذا كمثال مع مقارنة عمودين مع بعضهما.xlsm

تفضل اخى الكريم كان عليك استخدام خاصية البحث فى المنتدى قبل رفع المشاركة https://www.officena.net/ib/topic/39234-طريقة-تحويل-ملف-اكسل-الى-csv-أو-vcf/\ او يمكنك من هنا ايضا https://convertio.co/ar/xls-csv/

ما تقوله من الصعب عمله لأنى بأى سريال مثلا تريد ان أبدأ اول طالب من المدسة 2 وهكذا بالنسبة لباقى المدارس وعلى اى اساس يتم الترقيم والتسلسل للمدارس كلها ليس هناك شروط وضوابط لطلبك ؟ تمام انا معك اذا اعطيت المدرسة 1 سريال مثلا من 100 الى 145 ثم بعد ذلك بدأت المدرسة 2 فى الترقيم فبأى سريال ابدأ مع هذه المدرسة هل ب 146 ولا ابدأ من 100 كالبداية !!!!!!!!!!

اخى الكريم بارك الله فيك انا شرحت لك سابقا لابد من الضغط على Alt +f11 ثم فتح مديول جديد ووضع الكود الطويل المرسل لك سابقا ثم بعد ذلك وضع المعادلة كما وضحت لك مكانها فى الملف .

لماذا لم تضع كود المعادلة داخل الملف ؟!!!!!!!!! تفضل كله تمام . Classeur1.xlsm

تفضل كان عليك رفع ملف بالمطلوب من البداية Test.xlsx

تفضل هذا الكود اذا قمت بالكتابة فى العمود الأول A والعمود الثالث C سيعمل هذا الكود على تلوين المتشابه الغير متماثل باللون الأصفر Sub compare_cols122() Dim NameList As Worksheet Dim i As Long, j As Long Set NameList = Excel.Worksheets("Names") Dim rngNames As Range Set rngNames = Range("A1", Range("A1").Offset(Rows.Count - 1).End(xlUp)) Dim varNames As Variant varNames = rngNames.Value2 Dim rngData As Range Set rngData = Range("C1", Range("C1").Offset(Rows.Count - 1).End(xlUp)) Dim varData As Variant varData = rngData.Value2 Application.ScreenUpdating = False For i = LBound(varNames) + 1 To UBound(varNames) For j = LBound(varData) + 1 To UBound(varData) If varNames(i, 1) <> "" Then If InStr(1, varData(j, 1), varNames(i, 1), vbTextCompare) > 0 Then NameList.Cells(j, 3).Interior.ColorIndex = 6 NameList.Cells(i, 1).Interior.ColorIndex = 6 Exit For Else End If End If Next j Next i Application.ScreenUpdating = True End Sub

تفضل هذا الكود اذا قمت بالكتابة فى العمود الأول A والعمود الثالث C سيعمل هذا الكود على تلوين المتشابه الغير متماثل باللون الأصفر Sub compare_cols122() Dim NameList As Worksheet Dim i As Long, j As Long Set NameList = Excel.Worksheets("Names") Dim rngNames As Range Set rngNames = Range("A1", Range("A1").Offset(Rows.Count - 1).End(xlUp)) Dim varNames As Variant varNames = rngNames.Value2 Dim rngData As Range Set rngData = Range("C1", Range("C1").Offset(Rows.Count - 1).End(xlUp)) Dim varData As Variant varData = rngData.Value2 Application.ScreenUpdating = False For i = LBound(varNames) + 1 To UBound(varNames) For j = LBound(varData) + 1 To UBound(varData) If varNames(i, 1) <> "" Then If InStr(1, varData(j, 1), varNames(i, 1), vbTextCompare) > 0 Then NameList.Cells(j, 3).Interior.ColorIndex = 6 NameList.Cells(i, 1).Interior.ColorIndex = 6 Exit For Else End If End If Next j Next i Application.ScreenUpdating = True End Sub

تفضل لك ما طلبت Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Range("a1:a5,F4,B12,C3,E10"), Target) Is Nothing Then Target.Offset(0, 1).Select End If End Sub

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

الأمر بسيط جدا اولا عليك بفتح مديول جديد ووضع هذا الكود به كما هو بالملف المرسل لك سابقا 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