AbuuAhmed

عدلت في المعادلة ربما تعمل معك، جرب

=IF(F8*0.0199<1.99,1.99,IF(F8*0.0199>2.99,2.99,F8*0.0199))

الدالة، تتطلب النص وترتيب الدرجة في النص 1 للأول 2 للثاني:
 

Option Explicit

Function GetDeg(ByVal inText As String, DegSeq As Byte) As Variant
  Dim Pos1 As Integer, Pos2 As Integer
  Dim Deg As Variant
  
  GetDeg = ""
  If DegSeq < 1 Or DegSeq > 2 Then Exit Function
  
  Do While InStr(1, inText, "  ") > 0
     inText = Replace(inText, "  ", " ")
  Loop
  
  Pos2 = InStr(1, inText, " درج")
  If Pos2 = 0 Then Exit Function

  If DegSeq = 2 Then
    Pos2 = InStr(Pos2 + 1, inText, " درج")
    If Pos2 = 0 Then Exit Function
  End If
  
  Pos1 = InStrRev(inText, " ", Pos2 - 1)
  If Pos1 > 0 And Pos2 > 0 Then
    Deg = Mid(inText, Pos1 + 1, Pos2 - Pos1 - 1)
  End If
  
  If IsNumeric(Deg) Then GetDeg = Val(Deg)
End Function

ضفه في ملفك أو انشئ ملف جديد ووحدة نمطية جديدة والصق الشفرة/الكود

عملت لك حل بالكود
 

فصل الارقام عن الاحرف_01.xlsm

طلبك الآن يخالف طلبك الأول

ربما أنك لا تريد أن ترى في الأيام الباقي 30 يوم، إذا كان كذلك اعتره شهر وأضفه على الشهور وصفر الأيام.

طول الشهر 20 يوم_04.xlsm

3 ساعات مضت, Engsamir Ahmed said:

لو اردت تغيير الشهر ليكون 30 يوم هل استبدل 30 ب 20

ام هناك تعيديل فى كود vba

نعم صحيح،
ولا تعديل في كودر vba

طول الشهر 20 يوم_03.xlsm

في 8‏/4‏/2024 at 04:10, Engsamir Ahmed said:

فهل من طريقة

إذا لم تتابع فكيف نعرف حصلت على الحل أم لا!!
احتمال آخر للحل إذا كان فهمي لمطلبك صحيحا:

طول الشهر 20 يوم_02.xlsm

افحصه

طول الشهر 20 يوم.xlsm

حل آخر بدون كود vba:
 

=IF(RIGHT(A1,1)="-",VALUE(TRIM(LEFT(A1,LEN(A1)-1)))*-1,VALUE(TRIM(A1)))

المثال لا يوجد به أرقام بالموجب لذلك لا أضمن المعادلة ستنجح مع الأرقام الموجبة أو لا.

العلامة بالسالب_01.xlsx

كذلك اسم النموذج مختلف فالاسم في الكود UserForm وأنت مسميه UserForm1
فالتعديل بيكون بتبديل أول سطرين من:
 

Private Sub UserForm_Initialize()
   With ListView1

إلى:
 

Private Sub UserForm1_Initialize()
    With tbl

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

لم أرى إلا نطاق tbl فاستخدمته بدلا من ListView1
كما أنه في آخر سطر مناداة لإجراء غير موجنود فعطلته actualistion.
 

Private Sub UserForm_Initialize()
   'With ListView1
    With tbl
       .Gridlines = True 'affiche ou pas les lignes
       .View = lvwReport ' style de rapport
       .FullRowSelect = True ' permet de sélectionner une ligne dans la liste
       'création des en-tétes personnalisées avec leur largeur
       .ColumnHeaders.Add Text:="الرقم", Width:=1
       .ColumnHeaders.Add Text:="إسم المستفيد", Width:=60
       .ColumnHeaders.Add Text:="حساب المستفيد", Width:=90
       .ColumnHeaders.Add Text:="البنك", Width:=60
       .ColumnHeaders.Add Text:="المبلغ", Width:=60
       .ColumnHeaders.Add Text:="رقم الصك", Width:=60
       .ColumnHeaders.Add Text:="تاريخ إجراء المعاملة", Width:=60
    End With
    
    'Call actualistion 'on appelle la procédure qui actualise la listview
End Sub

والله أتعبني الموضوع، أخي يفترض أن يكون سعر البيع المطلوب للبيع (متوسط الأسهم حالياً) يدخل يدويا وليس معادلة.
جرب وخبرني.

111_01.xlsx

جرب هذه المعادلة:
 

=  ( (K6*K10) - ((K6*M7)-M6) ) / M7

وأينك عن هذا الموضوع؟!! ..
لا بد متابعة مواضيعك، ارجع للموضوع السابق وضع ملاحظاتك قبل فتح موضوع جديد.
 

في موضوع آخر هناك دوال لتأخذ تاريخين بداية ونهاية ثم ترجع المدة على شكل سنة شهر يوم
أما هذه الدالة تأخذ أيام فقط وتحولها إلى سنة شهر يوم، وهنا الدالة تفترض أن تاريخ البداية دائما هو بداية دورة الـ 400 سنة مثل:
1، 401، 801، 1201، 1601، 2001 وهكذا.
 

Function FixVal(inVal As Double, MinVal As Double, MaxVal As Double) As Double
    FixVal = inVal
    If inVal < MinVal Then FixVal = MinVal
    If inVal > MaxVal Then FixVal = MaxVal
End Function

Function Days2Period(ByVal Days As Long) As String
    Dim CurCal As VbCalendar
    Dim Gr2: Gr2 = Array(0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365, 396)
    Dim yy As Long, mm As Integer, dd As Integer
    Dim Cyc400 As Long, Cyc100 As Long, Cyc004 As Long, Cyc001 As Long
    Dim mmDays As Double, Leap As Byte
  
    CurCal = Calendar
    Calendar = vbCalGreg
  
    Cyc400 = Fix(Days / 146097):              Days = Days - Cyc400 * 146097
    Cyc100 = FixVal(Fix(Days / 36524), 0, 3): Days = Days - Cyc100 * 36524
    Cyc004 = FixVal(Fix(Days / 1461), 0, 24): Days = Days - Cyc004 * 1461
    Cyc001 = FixVal(Fix(Days / 365), 0, 3):   Days = Days - Cyc001 * 365
    
    yy = Cyc400 * 400 + Cyc100 * 100 + Cyc004 * 4 + Cyc001
    mm = FixVal(Round(Days / 29.5, 0), 0, 11)
  
    Leap = Day(DateSerial(yy + 1, 3, 0)) - 28
    mmDays = Gr2(mm) + IIf(mm > 1, Leap, 0)
    Do While mmDays > Days
        mm = mm - 1
        mmDays = Gr2(mm) + IIf(mm > 1, Leap, 0)
    Loop
  
    dd = Days - mmDays
    Days2Period = Format(yy, "00") & "-" & Format(mm, "00") & "-" & Format(dd, "00")
  
    Calendar = CurCal
End Function

Days_to_Year_Month_Day_01.xlsm

في 30‏/1‏/2024 at 10:59, ميدو63 said:

ممكن شيت اكسيل للتطبيق

Periods_Year_Month_Day_01.xlsm

15 ساعات مضت, lionheart said:

04-11-04
04-11-00

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

دالة من "أبو هاجر"
 

Function GetPeriod2(ByVal DateFm As Date, ByVal DateTo As Date, _
                    Optional yy As Integer, Optional mm As Byte, Optional dd As Byte) As String
  Dim TempDate As Date
  Dim m As Long
   
  DateFm = DateFm - 1

  m = DateDiff("m", DateFm, DateTo)
  TempDate = DateAdd("m", m, DateFm)
  If TempDate > DateTo Then
    m = m - 1
    TempDate = DateAdd("m", m, DateFm)
  End If
   
  yy = Fix(m / 12)
  mm = m Mod 12
  dd = DateDiff("d", TempDate, DateTo)

  GetPeriod2 = Format(yy, "00") & "-" & Format(mm, "00") & "-" & Format(dd, "00")
End Function

دالة من جعفر
 

Function YMDDif(ByVal sDate1 As Date, ByVal sDate2 As Date) As String
    Dim iYear As Integer
    Dim iMonth As Integer
    Dim iDay As Integer
    Dim dInterim1 As Date
    Dim D As Integer
    Dim m As Integer
    Dim Y As Integer

    sDate1 = sDate1 - 1
    
    iMonth = DateDiff("m", sDate1, sDate2)
    If day(sDate1) > day(sDate2) Then
        iMonth = iMonth - 1
    End If
    dInterim1 = DateAdd("m", iMonth, sDate1)
    iDay = DateDiff("d", dInterim1, sDate2)
    
    Y = iMonth \ 12
    m = iMonth Mod 12
    D = iDay
    
    YMDDif = Format(Y, "00") & "-" & Format(m, "00") & "-" & Format(D, "00")
End Function

دالة من "أبو هادي"
 

Function GetPeriod1(ByVal DateFm As Date, ByVal DateTo As Date, _
                    Optional yy As Integer, Optional mm As Byte, Optional dd As Byte) As String
  Dim yyFm As Long, yyTo As Long
  Dim mmFm As Integer, mmTo As Integer
  Dim ddFm As Integer, ddTo As Integer
  
  DateFm = DateFm - 1
  
  yyFm = Year(DateFm): mmFm = month(DateFm): ddFm = day(DateFm)
  yyTo = Year(DateTo): mmTo = month(DateTo): ddTo = day(DateTo)
  
  If ddFm = day(DateSerial(yyFm, mmFm + 1, 1) - 1) Then
    ddFm = 0: mmFm = mmFm + 1
  End If
  
  If ddTo = day(DateSerial(yyTo, mmTo + 1, 1) - 1) Then
    ddTo = 0: mmTo = mmTo + 1
  End If
  
  If ddTo - ddFm < 0 Then  '(1)
    ddTo = ddTo + day(DateSerial(yyTo, mmTo, 0)):   mmTo = mmTo - 1
    If ddTo - ddFm < 0 Then '(2)
      ddTo = ddTo + day(DateSerial(yyTo, mmTo, 0)): mmTo = mmTo - 1
    End If
  End If
  
  If mmTo < mmFm Then
    mmTo = mmTo + 12: yyTo = yyTo - 1
  End If
  
  yy = yyTo - yyFm
  mm = mmTo - mmFm
  dd = ddTo - ddFm
  GetPeriod1 = Format(yy, "00") & "-" & Format(mm, "00") & "-" & Format(dd, "00")
End Function

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

'  DateFm      DateTo       Period
'28/02/2010  01/02/2015    04-11-05

'01/03/2010  01/02/2015    04-11-04
'02/03/2010  01/02/2015    04-11-03
'03/03/2010  01/02/2015    04-11-02
'04/03/2010  01/02/2015    04-11-01
'05/03/2010  01/02/2015    04-11-00

'06/03/2010  01/02/2015    04-10-27

جربوا دوالكم وزودونا بنائجها.

لا أعلم إذا يوجد في الاكسل أم لا.
هذه دالة بالـ vba يمكنها أن تؤدي الغرض:
 

Function Between(Value As Variant, MinVal As Variant, MaxVal As Variant) As Variant
    If VarType(Value) = VarType(MinVal) And _
       VarType(Value) = VarType(MaxVal) Then
        Between = CBool(Value >= MinVal And Value <= MaxVal)
    Else
        Between = "Var type error"
    End If
End Function

لا بد تدخل على تنسيق خلية المدة وتجعلها نص.
 

Calcul IEP_06.xlsm

منذ ساعه, لزهر مدلل said:

ظهرت مشكلة أخرى و هي أن عدد الشهور 10 أو 1 يحسبها مثل بعضهما

وعليكم السلام 
احذف اسم الدالة VALUE لتصبح النتيجة نص بدلا من رقم كذلك المدخل Period للدالة calcIEP من Double إلى String
لتصبح الدالة بشكلها النهائي:

Function calcIEP(ByVal Period As String) As Double
    Dim yr(), yy As Byte, mm As Byte
    Dim Pr(), Per As Double, P As Byte
    
    yr = Array(6, 5, 10, 5)
    Pr = Array(0.02, 0.018, 0.015, 0.04)
    
    P = InStrRev(Period, ".")
    mm = IIf(P = 0, 0, Mid(Period, P + 1))
    Period = Fix(Period)
    
    For P = 1 To 4
        yy = yr(P - 1): Per = Pr(P - 1)
        
        If Period > yy And P < 4 Then
            Period = Period - yy
            calcIEP = calcIEP + yy * Per
        Else
            calcIEP = calcIEP + Period * Per + (Per / 12 * mm)
            Exit For
        End If
    Next P
End Function

Calcul IEP_05.xlsm

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

أو استخدم هذه الشفرة:
 

Sub Macro1()
    Sheets("101").Select
    
    If Asc(Mid(Range("C2"), Len(Range("C2")) - 2, 1)) <> 63 Then
        MsgBox "يبدو أنه قد تمت المعالجة من قبل"
        Exit Sub
    End If
    
    Columns("C:C").Select
    Selection.Replace What:=Mid(Range("C2"), Len(Range("C2")) - 2, 1), Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.NumberFormat = "#,##0.00"
    
    MsgBox "Done"
End Sub

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

Function getBalance(DumpVal) As Variant
    Dim sht1 As Worksheet, main As Worksheet
    Dim lrow As Integer, row As Integer
    Dim unit As String
    
    Set sht1 = Sheets("ورقة1")
    Set main = Sheets("رئيسي ")
    
    getBalance = ""
    
    With sht1
        lrow = .Range("B1").End(xlDown).row
        unit = Trim(.Cells(lrow, 3))
        If unit = "" Then Exit Function
        getBalance = -.Cells(lrow, 2)
    End With
    
    With main
        lrow = .Range("B1").End(xlDown).row
        For row = lrow To 2 Step -1
            If .Cells(row, 1) Like "*" & unit Then
                getBalance = .Cells(row, 2) + getBalance
                Exit For
            End If
        Next row
    End With
    
    Set sht1 = Nothing
    Set main = Nothing
End Function

getBalance_07.xlsm

حياك الله أستاذ @محمد هشام. هذه دالتي بعد فهمي لشرحك وإضافتك مزيد من البيانات المتنوعة.
 

Function getBalance(DumpVal) As Long
    Dim sht1 As Worksheet, main As Worksheet
    Dim lrow As Integer, row As Integer
    Dim unit As String
    
    Set sht1 = Sheets("ورقة1")
    Set main = Sheets("رئيسي ")
    
    With sht1
        lrow = .Range("B1").End(xlDown).row
        unit = .Cells(lrow, 3)
        getBalance = .Cells(lrow, 2)
    End With
    
    With main
        lrow = .Range("B1").End(xlDown).row
        For row = lrow To 2 Step -1
            If .Cells(row, 1) Like "*" & unit Then
                getBalance = .Cells(row, 2) - getBalance
                Exit For
            End If
        Next row
    End With
    
    Set sht1 = Nothing
    Set main = Nothing
End Function

getBalance_04.xlsm