توابع درخواستی

[كامران]

سلام به همه دوستانی که از این مطلب بازدید میکنن

همونطور که از اسم میبینید من اینجا میخوام توابع جدیدی رو که خودم برای کاربردهای شخصی نوشتم بذارم چون فکر کردم شاید کس دیگه ای هم به مشکل من بر بخوره و احتیاج به همچین توابعی داشته باشه پس شما هم خسیسی نکنید و اگه تابع جدیدی نوشتین اینجا بذارید تا دیگران هم استفاده بکنن

ظمنآ چون من علاقه خاصی به چالش و سرگرم شدن با vba دارم اگه برای کار خاصی احتیاج به تابعی داشتین که در اکسل وجود نداره اطلاع بدید شاید من یا بقیه دوستان بتونیم روش کار کنیم

تذکر : سوالتون رو کامل مطرح کنید و تمام خواسته هاتون رو از اون تابع بخصوص بگید

[كامران]

اضافه کردن شرح حال به تابع نوشته شده

بعنوان پست اول



قبل از گذاشتن هر تابع باید بدونیم که وقتی تابع رو نوشتیم برای اینکه در پنجره تابع شرح تابع و هر کدام از گزینه ها و شرطهای تابع به زبان فارسی بیاد باید چکار کنیم

برای اینکار باید از ماکروی زیر استفاده کنیم که میتونیم اونو بعنوان یه add-ins همراه تابع ذخیره کنیم و در صورت لزوم استفاده ش بکنیم

تذکر 1: اینکار برای هر تابع فقط یکبار لازمه مگر اینکه از متن راضی نباشد و بخواید عوضش کنید که باید دوباره ماکرو رو پس از تغییرات اجرا کنید تا تغییرات اعمال بشه

تذکر 2: وجود این ماکرو فقط یکبار روی اکسل نیازه و احتیاجی نیست که برای هر تابع یکبار ماکرو رو توی اکسل داشته باشید فقط کافیه برای هر تابع فقط گزینه های ماکرو رو مطابق تابع تغییر بدبد و اجراش کنید

تذکر 3: این ماکرو نوشته من نیست و از اینترنت دانلودش کردم

Sub FunctionDescription()


    
    'Delclaring the necessary variables
    Dim FuncName As String
    Dim FuncDesc As String
    Dim FuncCat As Variant
    
     'تعداد متغیرهای تابع
    Dim ArgDesc(1 To 4) As String
    
    'اسم تابع
    FuncName = "FrictionFactor"
    
    'شرح تابع (کاری که انجام میده)
    FuncDesc = "Calculates the friction factor of a pipe using Churchill's equation."
    
    'تابع باید در کدام دسته بندی اکسل قرار بگیرد (لیست آخر)
    FuncCat = 15
    
    'You can also use instead of numbers the full category name, for example:
    'FuncCat = "Engineering"
    'Or you can define your own custom category:
    'FuncCat = "My VBA Functions"
    
    'شرح و قوانین هر متغیر
    ArgDesc(1) = "Pipe Roughness in m"
    ArgDesc(2) = "Pipe Diameter in m"
    ArgDesc(3) = "Fluid Velocity in m/s"
    ArgDesc(4) = "Fluid Viscosity in m2/s"


    
    'فرمول این ماکرو (در این فرمول هیچ تغییری ندهید)
    Application.MacroOptions _
        Macro:=FuncName, _
        Description:=FuncDesc, _
        Category:=FuncCat, _
        ArgumentDescriptions:=ArgDesc
    
    'دسته بندی توابع
    
    Select Case FuncCat
        Case 1: FuncCat = "Financial"
        Case 2: FuncCat = "Date & Time"
        Case 3: FuncCat = "Math & Trig"
        Case 4: FuncCat = "Statistical"
        Case 5: FuncCat = "Lookup & Reference"
        Case 6: FuncCat = "Database"
        Case 7: FuncCat = "Text"
        Case 8: FuncCat = "Logical"
        Case 9: FuncCat = "Information"
        Case 10: FuncCat = "Commands"
        Case 11: FuncCat = "Customizing"
        Case 12: FuncCat = "Macro Control"
        Case 13: FuncCat = "DDE/External"
        Case 14: FuncCat = "User Defined default"
        Case 15: FuncCat = "Engineering"
        Case Else: FuncCat = FuncCat ' اسم دلخواه
    End Select


    'Inform the user about the process.
    MsgBox FuncName & " was successfully added to the " & FuncCat & " category!", vbInformation, "Done"
    
End Sub

اسامی و شرح های این ماکرو برای نمونه است و شما باید آنها را مطابق نیاز خود تغییر بدهید
تعداد آرگومانهای ماکرو و شرح آنها باید با تعداد نوشته شده تابع برابر باشد (آنها را مطابق نیاز کم و زیاد کنید)

[كامران]

محاسبه جمع کد اسکی تمام حروف یک متن

بعضی وقتها لازمه بدونیم ارزش یک متن از نظر کدهای اسکی چقدره (مثلا وقتی بخوایم چند سلول رو بر اساس متن داخلش مرتب کنیم)

این تابع اینکار رو برامون انجام میده

Function valtxt(text)


    Ln = Len(text)
        For a = 1 To Ln
            valtxt = valtxt + Asc(Mid(text, a, 1))
        Next a
        
    valtxt = valtxt + Ln


End Function

[كامران]

جدا کردن قسمت عددی یک متن

تابع زیر از یک متن یا کلمه قسمت عددی اون رو جدا میکنه و بقیه رو خذف میکنه

مثال : کلمه ورودی = اعتبار 150000 تومان
جواب : 150000

Function GETNUM(text)


    t = text
    Ln = Len(t)
    t2 = ""
        If Ln = 0 Then
            GETNUM = "#error"
            Exit Function
        End If
        
        For a = 1 To Ln
            t1 = Mid(t, a, 1)
            as1 = Asc(t1)
                If as1 < 48 Or as1 > 57 Then
                    GoTo nx
                End If
            t2 = t2 + t1
nx:
        Next a
      t2 = Val(t2)
      GETNUM = t2




End Function

[كامران]

جدا سازی قسمت متنی یک عبارت

این تابع درست عکس تابع قبلی کار میکنه

مثال: کلمه ورودی = اعتبار 150000 تومان
جواب: اعتبار تومان

Function GETTXT(text)


    t = text
    Ln = Len(t)
    t2 = ""
        If Ln = 0 Then
            GETTXT = "#error"
            Exit Function
        End If
        
        For a = 1 To Ln
            t1 = Mid(t, a, 1)
            as1 = Asc(t1)
                If as1 >= 48 And as1 <= 57 Then
                    GoTo nx
                End If
            t2 = t2 + t1
nx:
        Next a


      GETTXT = t2




End Function

[كامران]

پخش کردن یک عبارت در سلولهای جدا

این تابع دقیقآ برعکس تابع CONCATENATE کار میکنه یعنی یک عبارت رو میگیره و با توجه به فاصله های بین کلمات اونها رو توی سلولهای جداگانه مینویسه

Function PHRtoCELL(phrase, term)

    Dim no(50), wd(50)
    PHRtoCELL = ""
    ph = phrase
    tr = term
        
    Ln = Len(ph)
    no(0) = InStr(1, ph, " ")
        If no(0) = 0 Then
            PHRtoCELL = ph
            Exit Function
        End If
        
        If Ln = 0 Then
            PHRtoCELL = "#error"
            Exit Function
        End If
        x = 1
        y = 1
        For a = 1 To Ln
            no(x) = InStr(y + a, ph, " ")
                If no(x) <> 0 Then
                    y = no(x)
                    x = x + 1
                End If
        Next a
    
    no(0) = 0
        For a = 1 To x - 1
            wd(a) = Mid(ph, no(a - 1) + 1, no(a) - no(a - 1))
        Next a
    wd(x) = Right(ph, Ln - no(x - 1))


    PHRtoCELL = wd(tr)


End Function

دو آرگومان تابع اولی عبارت ورودیه و دومی مشخص میکنه که چندمین کلمه رو میخواید نمایش بده

[كامران]

نمایش تاریخ با حروف فارسی

این تابع تاریخ دلخواه شمارو (شمسی یا میلادی ) میگیره و بصورت متن فارسی نشون میده

Function DATEtoALFA(year, Extra_year, month, mcat, day)
   
    yyyy = year
    mm = month
    dd = day
    yc = Extra_year
    mc = mcat
   
    ly = Len(yyyy)
         
        If yc <= 0 Then
           DATEtoALFA = "اعداد اضافي بايد بزرگتر از صفر باشد"
        End If
        
        If Len(yc) = 1 Then
            yc = "0" & yc
        End If
        
        If ly = 2 Then
            yyyy = yc & yyyy
            ly = 4
        End If
                
        If mm < 1 Or mm > 12 Then
            DATEtoALFA = " ماه بايد يک عدد مثبت بين 1 تا 12 باشد"
            Exit Function
        End If
        
        If ly = 3 Or ly = 1 Then
            yyyy = "0" & yyyy
            ly = ly + 1
        End If
        
        If dd < 1 Or dd > 31 Then
            DATEtoALFA = " روز بايد يک عدد مثبت بين 1 تا 31 باشد"
            Exit Function
        End If
        
        If mc <> 1 And mc <> 0 Then
            DATEtoALFA = " کنترل کننده ماه بايد 0 يا 1 باشد"
            Exit Function
        End If
         
        If ly = 2 Then
            y34 = yyyy
        Else
            y34 = Right(yyyy, 2)
        End If
        
        If Val(y34) = 0 Then
            ytm = ""
        Else
            ytm = " و "
        End If
    
        If ly = 4 Then
            yal4 = Left(yyyy, 1)
            yal40 = " هزار"
        End If
        
        If yal4 = 0 Then
            yal40 = ""
        End If
       
        If ly = 4 Then
            yal3 = Mid(yyyy, 2, 1)
        End If
    
    yal1 = Right(yyyy, 2)
        If ly = 4 Then
            If Val(yal1) > 19 Then
                yal21 = Mid(yyyy, 3, 1)
                yal20 = Right(yyyy, 1)
            End If
        Else
            If Val(yal1) > 19 Then
                yal21 = Left(yyyy, 1)
                yal20 = Right(yyyy, 1)
            End If
        End If
    
          
        If mc = 0 Then
            shm = mm
        Else
            mmt = mm
        End If
    
    fnum = dd
    
    Select Case fnum
        Case 1: fnum = "اول"
        Case 2: fnum = "دوم"
        Case 3: fnum = "سوم"
        Case 4: fnum = "چهارم"
        Case 5: fnum = "پنجم"
        Case 6: fnum = "ششم"
        Case 7: fnum = "هفتم"
        Case 8: fnum = "هشتم"
        Case 9: fnum = "نهم"
        Case 10: fnum = "دهم"
        Case 11: fnum = "يازدهم"
        Case 12: fnum = "دوازدهم"
        Case 13: fnum = "سيزدهم"
        Case 14: fnum = "چهاردهم"
        Case 15: fnum = "پانزدهم"
        Case 16: fnum = "شانزدهم"
        Case 17: fnum = "هفدهم"
        Case 18: fnum = "هجدهم"
        Case 19: fnum = "نوزدهم"
        Case 20: fnum = "بيستم"
        Case 21: fnum = "بيست و يکم"
        Case 22: fnum = "بيست و دوم"
        Case 23: fnum = "بيست و سوم"
        Case 24: fnum = "بيست و چهارم"
        Case 25: fnum = "بيست و پنجم"
        Case 26: fnum = "بيست و ششم"
        Case 27: fnum = "بيست و هفتم"
        Case 28: fnum = "بيست و هشتم"
        Case 29: fnum = "بيست و نهم"
        Case 30: fnum = "سي ام"
        Case 31: fnum = "سي و يکم"
    End Select


    Select Case shm
        Case 1: shm = "فروردين"
        Case 2: shm = "ارديبهشت"
        Case 3: shm = "خرداد"
        Case 4: shm = "تير"
        Case 5: shm = "مرداد"
        Case 6: shm = "شهريور"
        Case 7: shm = "مهر"
        Case 8: shm = "آبان"
        Case 9: shm = "آذر"
        Case 10: shm = "دي"
        Case 11: shm = "بهمن"
        Case 12: shm = "اسفند"
    End Select
    
    Select Case mmt
        Case 1: mmt = "ژانويه"
        Case 2: mmt = "فوريه"
        Case 3: mmt = "مارس"
        Case 4: mmt = "آوريل"
        Case 5: mmt = "مي"
        Case 6: mmt = "ژوئن"
        Case 7: mmt = "جولاي"
        Case 8: mmt = "اگوست"
        Case 9: mmt = "سپتامبر"
        Case 10: mmt = "اکتبر"
        Case 11: mmt = "نوامبر"
        Case 12: mmt = "دسامبر"
    End Select
    
    Select Case yal1
        Case 1: yal1 = "يک"
        Case 2: yal1 = "دو"
        Case 3: yal1 = "سه"
        Case 4: yal1 = "چهار"
        Case 5: yal1 = "پنج"
        Case 6: yal1 = "شش"
        Case 7: yal1 = "هفت"
        Case 8: yal1 = "هشت"
        Case 9: yal1 = "نه"
        Case 10: yal1 = "ده"
        Case 11: yal1 = "يازده"
        Case 12: yal1 = "دوازده"
        Case 13: yal1 = "سيزده"
        Case 14: yal1 = "چهارده"
        Case 15: yal1 = "پانزده"
        Case 16: yal1 = "شانزده"
        Case 17: yal1 = "هفده"
        Case 18: yal1 = "هجده"
        Case 19: yal1 = "نوزده"
        Case Else: yal1 = ""
    End Select
        
    Select Case yal21
        Case 1: yal21 = ""
        Case 2: yal21 = "بيست"
        Case 3: yal21 = "سي"
        Case 4: yal21 = "چهل"
        Case 5: yal21 = "پنجاه"
        Case 6: yal21 = "شصت"
        Case 7: yal21 = "هفتاد"
        Case 8: yal21 = "هشتاد"
        Case 9: yal21 = "نود"
    End Select
    
    Select Case yal20
        Case 0: yal20 = ""
        Case 1: yal20 = " و يک"
        Case 2: yal20 = " و دو"
        Case 3: yal20 = " و سه"
        Case 4: yal20 = " و چهار"
        Case 5: yal20 = " و پنج"
        Case 6: yal20 = " و شش"
        Case 7: yal20 = " و هفت"
        Case 8: yal20 = " و هشت"
        Case 9: yal20 = " و نه"
    End Select
        
    Select Case yal3
        Case 0: yal3 = ""
        Case 1: yal3 = "صد "
        Case 2: yal3 = "دويست "
        Case 3: yal3 = "سيصد "
        Case 4: yal3 = " چهارصد"
        Case 5: yal3 = " پانصد"
        Case 6: yal3 = "ششصد "
        Case 7: yal3 = "هفتصد "
        Case 8: yal3 = "هشتصد "
        Case 9: yal3 = "نهصد "
    End Select
    
    Select Case yal4
        Case 0: yal4 = ""
        Case 1: yal4 = "يک"
        Case 2: yal4 = "دو"
        Case 3: yal4 = "سه"
        Case 4: yal4 = "چهار"
        Case 5: yal4 = "پنج"
        Case 6: yal4 = "شش"
        Case 7: yal4 = "هفت"
        Case 8: yal4 = "هشت"
        Case 9: yal4 = "نه"
    End Select
    
        If mc = 0 Then
            mm1 = shm
        Else
            mm1 = mmt
        End If
    
        If mc = 0 Then
            endt = " هجري شمسي"
        Else
            endt = " ميلادي"
        End If
        
        If yal4 <> "" Then
            an = " و "
        Else
            en = ""
        End If
        
               
    DATEtoALFA = fnum & " ماه " & mm1 & " سال " & y12 & yal4 & yal40 & an & yal3 & ytm & yal1 & yal21 & yal20 & endt
      


End Function

شرح آرگومانها :

year = سال که میتواند 2 یا 4 رقمی باشد
Extra_year = در سالهای 2 رقمی دو رقم اول سال را تشکیل میدهد
month = ماه
mcat = تعیین میکنه خروجی شمسی یا میلادی باشه
day = روز

مثال
تابع = DATEtoALFA(49;31;1;0;25)
نتیجه = بيست و پنجم ماه فروردين سال سه هزار و صد و چهل و نه هجري شمسي

تابع = DATEtoALFA(49;31;1;1;25)
نتیجه = بيست و پنجم ماه ژانويه سال سه هزار و صد و چهل و نه ميلادي

[كامران]

نمایش تاریخ با حروف فارسی مدل دوم

این تابع مشابه تابع قبلیه با این فرق که بجای سال و ماه و روز تاریخ ورودی باید مطابق با فرمت تاریخ اکسل باشه

Function DATEtoALFA2(Datetext, Dformat, Mcatg)


    dt = Datetext
    mc = Mcatg
    df = Dformat
    
        If df <> 0 And df <> 1 Then
            DATEtoALFA2 = "فرمت تاريخ اشتباه است 0 يا 1"
            Exit Function
        End If
        
        If mc <> 0 And mc <> 1 Then
            DATEtoALFA2 = "فرمت ماه اشتباه است 0 يا 1"
            Exit Function
        End If
        
    ld = Len(dt)
        
    q1 = InStr(1, dt, "/")
        If q1 <> 0 Then
            q2 = InStr(q1 + 1, dt, "/")
                If q2 = 0 Then
                    DATEtoALFA2 = "تاريخ را بصورت صحيح وارد کنيد"
                    Exit Function
                End If
        End If
        
        If q1 <> 5 Then
            If ld - q2 < 4 Then
                DATEtoALFA2 = "سال بايد 4 رقمي باشد"
                Exit Function
            End If
        End If
        
        If q1 = 5 Then
            exy = Left(dt, 4)
                If df = 0 Then
                    exm = Mid(dt, q1 + 1, q2 - q1 - 1)
                    exd = Right(dt, ld - q2)
                Else
                    exd = Mid(dt, q1 + 1, q2 - q1 - 1)
                    exm = Right(dt, ld - q2)
                End If
        Else
            exy = Right(dt, 4)
                If df = 0 Then
                    exd = Left(dt, q1 - 1)
                    exm = Mid(dt, q1 + 1, q2 - q1 - 1)
                Else
                    exm = Left(dt, q1 - 1)
                    exd = Mid(dt, q1 + 1, q2 - q1 - 1)
                End If
        End If
        
        
       DATEtoALFA2 = DATEtoALFA(exy, yc, exm, mc, exd)
            
End Function

شرح آرگومانها :

Datetext = تاریخ ورودی
Dformat = اگر 0 باشد 2 رقم وسط ممیزها ماه و اگر 1 باشد روز حساب میشود
Mcatg = تعیین میکند تاریخ شمسی یا میلادی باشد

مثال :
تابع = DATEtoALFA2("2017/06/06";1;1)
نتیجه = ششم ماه ژوئن سال دو هزار و و هفده ميلادي

تابع = DATEtoALFA2("2017/06/06";1;0)
نتیجه = ششم ماه شهريور سال دو هزار و و هفده هجري شمسي

تذکر مهم :

1 - این تابع با تابع قبلی کار میکند یعنی برای کار کردن باید تابع قبلی وجود داشته باشد
2 - در تاریخ ورودی سال باید 4 رقمی و کل عدد داخل "" باشد

[كامران]

برعکس کردن عبارت

این تابع یک عبارت رو میگیره و از حرف آخر به اول مینویسه

Function REVWORD(phrase)


    lp = Len(phrase)
        
        If lp > 512 Then
            REVWORD = "طول عبارت نبايد از 512 کاراکتر بزرگتر باشد"
            Exit Function
        End If
        
        For a = 1 To lp
            ph = Mid(phrase, a, 1)
            aph2 = ph & aph2
        Next a
        
    REVWORD = aph2
    
End Function

تابع : REVWORD(123456789)
جواب : 987654321