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

YZC51

每个工作表都另存为带宏的工作簿
Sub savetofile()
   Application.ScreenUpdating = False
   Dim folder As String
   folder = ThisWorkbook.Path & "\班级成绩表"
   If Len(Dir(folder, vbdirdctory)) = 0 Then MkDir folder
Dim sht As Worksheet
For Each sht In Worksheets
   sht.Copy
'   ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"
   ActiveWorkbook.SaveAs folder & "\" & sht.Name, 52
   ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub

c2222y

谢楼主分享

YZC51

Sub 相片拍照日期()
    Dim fd As FileDialog
    On Error Resume Next
    Dim stMedd As String
    stMedd = "请选择文件目录："
    Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
    If Not obMapp Is Nothing Then
        GetDirectory = obMapp.self.Path & "\"
    Else
       Exit Sub
    End If

    Dim c As Long, R As Long, i As Long
    Dim FileName As Object, ObjShell As Object, ObiFolder As Object
    Set ObjShell = CreateObject("shell.Application")
    Set ObiFolder = ObjShell.Namespace(GetDirectory)
    c = 0
    For i = 0 To 34
        If i = 0 Or i = 3 Or i = 4 Or i = 5 Or i = 25 Then
            c = c + 1
            Cells(1, c) = ObiFolder.getdetailsof(ObiFolder.Items, i)
        End If
    Next i
    R = 1
    For Each FileName In ObiFolder.Items
        c = 0
        R = R + 1
        For i = 0 To 34
            If i = 0 Or i = 3 Or i = 4 Or i = 5 Or i = 25 Then
                c = c + 1
                Cells(R, c) = ObiFolder.getdetailsof(FileName, i)
            End If
        Next i
    Next FileName
    'ActiveSheet.ListObjects.Add xlSrcRange, [A1].CurrentRegion
    Set fd = Nothing
End Sub

YZC51

每10分钟自动备份文件
Sub auto_open()                                     '打开文件后每10分钟执行宏
    Application.OnTime Now + TimeValue("00:10:00"), "auto_open"
    Call 备份
End Sub

Sub 备份()
    Dim yy, y
    y = Format(Now, "ddhhmmss\.")                   '时间
    yy = Replace(ActiveWorkbook.FullName, ".", y)   '当前工作簿的路径和名称
    ActiveWorkbook.SaveCopyAs yy
End Sub

YZC51

附件请参考
每10分钟自动备份文件.rar (20.33 KB, 下载次数: 79)

2018-8-10 09:19 上传

点击文件名下载附件

YZC51

优化下
Public yzc
Sub auto_open()                                     '打开文件后每10分钟执行宏
    Application.OnTime Now + TimeValue("00:10:00"), "auto_open"
    If yzc > 0 Then Call 备份
    yzc = yzc + 1
End Sub

Sub 备份()
    Dim yy, y
'    y = Format(Now, "ddhhmmss\.\x")                   '时间
    y = Format$(yzc, "000.\x")                          '时间
    yy = Replace(ActiveWorkbook.FullName, ".x", y)   '当前工作簿的路径和名称
    ActiveWorkbook.SaveCopyAs yy
End Sub

YZC51

校正后的公历农历互转函数
http://club.excelhome.net/thread-976128-2-1.html

YZC51

'添加 B2H 自定义函数，方便转换为16进制数据格式。
Private Const ylData = "AB500D2,4BD0883," _
        & "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
        & "A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,D6A00CB,ADA027B,95B00D3,49717C9,49700DC," _
        & "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
        & "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
        & "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
        & "B5500CE,535157F,4DA00D6,A5B00CB,457137C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
        & "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
        & "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
        & "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,95700CE,4AF057F," _
        & "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
        & "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
        & "B4A00CB,BAA047B,AD500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
        & "6AA00D4,AD500C9,5B5027A,4B600D2,A6E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
        & "76A037B,96D00D3,4AE0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
        & "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
        & "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
        & "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _
        & "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _
        & "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
        & "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"

Private Const ylMd0 = "初一,初二,初三,初四,初五,初六,初七,初八,初九,初十,十一,十二,十三,十四,十五," _
        & "十六,十七,十八,十九,二十,廿一,廿二,廿三,廿四,廿五,廿六,廿七,廿八,廿九,三十"

Private Const ylMn0 = "正,二,三,四,五,六,七,八,九,十,冬,腊"
Private Const ylTianGan0 = "甲乙丙丁戊已庚辛壬癸"
Private Const ylDiZhi0 = "子丑寅卯辰巳午未申酉戌亥"
Private Const ylShu0 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"
Public dic As New Dictionary, dic1 As New Dictionary

'以下函数来自网络

'公历日期转农历
Function GetYLDate(ByVal strDate As String) 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 mm0 = "闰" & mm0
    GetYLDate = "农历" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0
aErr:
End Function

Private Function H2B(ByVal strHex As String) As String
    Dim i As Integer, i1 As Integer, tmpV As String
    Const hStr = "0123456789ABCDEF"
    Const bStr = "0000000100100011010001010110011110001001101010111100110111101111"
    tmpV = UCase(Left(strHex, 3))
    '十六进制转二进制
    For i = 1 To Len(tmpV)
        i1 = InStr(hStr, Mid(tmpV, i, 1))
        H2B = H2B & Mid(bStr, (i1 - 1) * 4 + 1, 4)
    Next
    H2B = H2B & Mid(strHex, 4, 2)
    '十六进制转十进制
    H2B = H2B & "0" & CStr(Val("&H" & Right(strHex, 2)))
End Function
Private Function B2H(ByVal strHex As String) As String '
    Dim i As Integer, tmpV As String
    tmpV = Left(strHex, 12)
    '二进制转十六进制
    For i = 1 To Len(tmpV) Step 4
        B2H = B2H & N2N(Mid(tmpV, i, 4))    '头12个月的大小转16进制
    Next
   B2H = B2H & Mid(strHex, 13, 2)           '第13个月的大小，2进制；闰几月，16进制1-ABC
    '十进制转十六进制
B2H = B2H & N2N(Right(strHex, 4), 10)          '春节的公历日期,十进制转十六进制
End Function

YZC51

'配合上面的函数需要
'制作于2018-7-23 yzc51
'十进制转N进制***
Public Function D2N(y As Long, Optional x = 16) As String
    ar = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
    If y = 0 Then D2N = "0"
    Do While y > 0                                  '辗转相除法的循环；
        y1 = y \ x: Z = (y / x - y1) * x            'y1为上次的商，z为相除后余数；
        D2N = Mid(ar, Z + 1, 1) & D2N               'D2N是每次的余数连成的字符串；
        y = y1                                      'y为下次要进行除法的被除数。
    Loop
End Function

'N进制转十进制***
Function N2D(y, Optional x = 16)
    ar = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
    zz = Len(y)
    For i = 1 To zz
        Z = InStr(ar, Mid(y, i, 1)) - 1
        N2D = N2D + Z * x ^ (zz - i)
    Next
End Function

'任意进制转十进制再转任意进制
Function N2N(k1, Optional n1 = 2, Optional n2 = 16)
    N2N = D2N(N2D(k1, n1), n2)
End Function

游乐缘

感谢楼主的分享！很多自定义函数都非常有用