自定义函数--提取单元格内多个被分开的数字

YZC51

谢谢老师鼓励。公历转农历再增加几个参数！

'以下函数来自网络

'公历日期转农历
Function GetYLDate(ByVal strDate As String, Optional Part As Integer = 0) As String
On Error GoTo aErr
    If Not IsDate(strDate) Then Exit Function
    Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer
    setDate = CDate(strDate)
    tYear = Year(setDate): tMonth = Month(setDate): tDay = Day(setDate)
    '如果不是有效有日期，退出
    If tYear > 2100 Or tYear < 1900 Then Exit Function
    Dim daList() As String * 18, conDate As Date, thisMonths As String
    Dim AddYear As Integer, AddMonth As Integer, AddDay As Integer, getDay As Integer
    Dim YLyear As String, YLShuXing As String
    Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2
    Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer
    '加载2年内的农历数据
    ReDim daList(tYear - 1 To tYear)
    daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))
    daList(tYear) = H2B(Mid(ylData, (tYear - 1900 + 1) * 8 + 1, 7))
    AddYear = tYear
initYL:
    AddMonth = CInt(Mid(daList(AddYear), 15, 2))
    AddDay = CInt(Mid(daList(AddYear), 17, 2))
    conDate = DateSerial(AddYear, AddMonth, AddDay)     '农历新年日期
    getDay = DateDiff("d", conDate, setDate) + 1        '相差天数
    If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL
    thisMonths = Left(daList(AddYear), 14)
    RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
    If RunYue1 > 0 Then                                  '有闰月
        thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
    End If
    thisMonths = Left(thisMonths, 13)
    For i = 1 To 13                                      '计算天数
        mDays = 29 + CInt(Mid(thisMonths, i, 1))
        If getDay > mDays Then
            getDay = getDay - mDays
        Else
            If RunYue1 > 0 Then
                If i = RunYue1 + 1 Then RunYue = True
                If i > RunYue1 Then i = i - 1
            End If
            
            AddMonth = i
            AddDay = getDay
            Exit For
        End If
    Next
    dd0 = Split(ylMd0, ",")(AddDay - 1)
    mm0 = Split(ylMn0, ",")(AddMonth - 1) + "月"
    For i = 0 To 59
        ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)
    Next i
    YLyear = ganzhi((AddYear - 4) Mod 60)
    YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1)
    If RunYue Then m0 = "闰"
    GetYLDate = "农历" & YLyear & "(" & YLShuXing & ")年" & m0 & mm0 & dd0
    YLNYR = AddYear & "-" & AddMonth & "-" & AddDay
    GetYLDate = Choose(Part + 1, GetYLDate, YLyear, m0 & mm0, dd0, YLShuXing, YLNYR, AddYear, m0 & AddMonth, AddDay)
aErr:
End Function

YZC51

Part 参数
0、农历已亥(猪)年正月三十
1、庚子
2、三月
3、初一
4、鼠
5、1900-6-1
6、1900 农历年份
7、8       农历月份
8、1       农历日期

WYS67

YZC51 发表于 2018-7-1 11:56
十进制与任意进制互转

Function DEC2N(k, Optional x = 3) '十进制转任意进制

老师：以上三个自定义函数，最好有附件加以举例说明，以方便像我们这些门外汉们学习实践。

YZC51

WYS67 发表于 2018-9-5 15:35
老师：以上三个自定义函数，最好有附件加以举例说明，以方便像我们这些门外汉们学习实践。

好的，不过没有动力吖！

WYS67

YZC51 发表于 2018-9-5 17:09
好的，不过没有动力吖！

哈哈！理由很强大！

YZC51

WYS67 发表于 2018-9-5 17:50
哈哈！理由很强大！

抱歉！昨天有事，今天刚看到。
请参考！
http://club.excelhome.net/thread-1422204-1-1.html
附件手头已经没有了！

WYS67

谢谢！这个附件里您写的代码我都已下载保存，正在学习中。

YZC51

与上面函数配套
'农历转公历日期
'secondMonth 为真，则表示当 tMonth 是闰月时，取第二个月
Function GetDate(nlrq, Optional secondMonth As Boolean = False) As String
    Dim tYear, tMonth, tDay

On Error GoTo aErr

    nlrq = Replace(nlrq, "-", " ")

    tYear = Split(nlrq)(0)
    tMonth = Split(nlrq)(1)
    tDay = Split(nlrq)(2)
If InStr(1, tMonth, "闰") > 0 Then tMonth = Mid(tMonth, 2): secondMonth = True
    If tYear > 2100 Or tYear < 1899 Or tMonth > 12 Or tMonth < 1 Or tDay > 30 Or tDay < 1 Then Exit Function
   
    Dim thisMonths As String, ylNewYear As Date, toMonth As Integer
    Dim mDays As Integer, RunYue1 As Integer, i As Integer
    thisMonths = H2B(Mid(ylData, (tYear - 1899) * 8 + 1, 7))
   
    If tDay > 29 + CInt(Mid(thisMonths, tMonth, 1)) Then Exit Function
   
    ylNewYear = DateSerial(tYear, CInt(Mid(thisMonths, 15, 2)), CInt(Mid(thisMonths, 17, 2)))     '农历新年日期
   
    thisMonths = Left(thisMonths, 14)
    RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
   
    toMonth = tMonth - 1
    If RunYue1 > 0 Then                                  '有闰月
        thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
        If tMonth > RunYue1 Or (secondMonth And tMonth = RunYue1) Then toMonth = tMonth
    End If
    thisMonths = Left(thisMonths, 13)
        
    mDays = 0
    For i = 1 To toMonth
        mDays = mDays + 29 + CInt(Mid(thisMonths, i, 1))
    Next
    mDays = mDays + tDay
   
    GetDate = ylNewYear + mDays - 1

aErr:
   
End Function

YZC51

Function WLOOKUP(X As Range, M As Variant, Optional a = 1, Optional b = 2)
    '比VLOOKUP函数更强大的函数:参数 a 查询第几个；b 返回第几列，可以为负数。
    Dim i As Integer
    i = Application.CountIf(M, X)
    Set M = Intersect(M.Parent.UsedRange, M)
    For Each MR In M
       If MR.Value = X Then
           y = y + 1
         If y > i Then Exit Function
           If y = a Then
           WLOOKUP = MR.Offset(0, b).Value
           End If
         End If
    Next MR
End Function

YZC51

'计算年柱（公元前9000年---公元9999年内有效！
Function YZC(Years) '皇帝元年公元前2697年
    If Years = "" Then YZC = "": Exit Function
    If Years = 0 Then YZC = "": Exit Function
    If Years < 0 Then Years = Years + 1
    Years = Years + 9000
    YZC = Mid("庚辛壬癸甲乙丙丁戊己", (Years Mod 10) + 1, 1) _
    & Mid("申酉戌亥子丑寅卯辰巳午未", (Years Mod 12) + 1, 1)
End Function