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

YZC51

Function TimeBJ(Optional ByVal num As Integer = 0) '网络时间
    arr = Split("北京,纽约,堪培拉,巴黎,东京,莫斯科,伦敦", ",")
    On Error Resume Next
    Application.Volatile
    Dim http
    URL = "http://www.24timemap.com/"
    With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", URL, False
    .send
    If .ReadyState <> 4 Then
    Exit Function
    End If
    st = .responseText
    End With
    a = Split(st, "tzone(")
    TimeBJ = arr(num) & Format(Left(a(num + 2), 10) / 86400 + 25569 + 1 / 3, "时间 yyyy-mm-dd hh:mm:ss")
    If num = 5 Then TimeBJ = arr(num) & Format(Left(a(num + 2), 10) / 86400 + 25569 + 1 / 8, "时间 yyyy-mm-dd hh:mm:ss")
End Function

YZC51

Sub Main()'获取网络时间
    Dim strText As String
    With CreateObject("MSXML2.XMLHTTP")
'        .Open "GET", "https://www.baidu.com/index.php", False
        .Open "HEAD", "https://www.baidu.com/index.php", False
     '   .Option(6) = false '禁止重定向
        .send
        strText = .getResponseHeader("Date")
'        strText = .getallResponseHeaders'获取完整包头配合HEAD
        If Len(strText) > 10 Then
            MsgBox DateAdd("h", 8, Split(Replace(strText, " GMT", ""), ",")(1))
        Else
            MsgBox Now
        End If
    End With
End Sub

YZC51

Function myjoin(rng, Optional x = "", Optional y = 0)
'作用：用任意连接符连接文本
    arr = rng
    ss = ""
    For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
'       If arr(i, j) <> "" Then ss = ss & arr(i, j)
         ss = ss & arr(i, j)
    Next
    Next
    myjoin = Mid(ss, 1 + Len(x))
    If y Then myjoin = Len(ss)
End Function

YZC51

自动排楼层6层.xlsm
自动排楼层6层.rar (494.23 KB, 下载次数: 59)

2019-1-31 10:49 上传

点击文件名下载附件

YZC51

更新
Function WLOOKUP(X As Range, M As Variant, Optional a = 1, Optional b = 2)
'比VLOOKUP函数更 强 大的函数:参数 X 为查找内容；M 为查找区域；
'a 查询第几个,0为最后一个,小于0输出有几个被查找内容；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 a = 0 And y = i Then
                WLOOKUP = MR.Offset(0, b).Value
            Else
                If y = a Then WLOOKUP = MR.Offset(0, b).Value
            End If
         End If
    Next MR
    If a < 0 Then WLOOKUP = i
End Function

YZC51

Function DLOOKUP(X, Z, M, Optional a = 1, Optional b = 3)
'比VLOOKUP函数更强大的双条件查找函数。参数说明： X、Z 为需要查找内容；M 为查找区域；
'a 查询第几个,0为最后一个,-1 为倒数第二个内容，小于-1输出有几个被查找内容；b 返回第几列。
    On Error Resume Next
    i = Application.CountIf(M, X)
    i1 = Application.CountIf(M, Z)
    i = Application.Min(i, i1)
   arr = M
    For j = 1 To UBound(arr)
       If arr(j, 1) = X And arr(j, 2) = Z Then
           Y = Y + 1
         If Y > i Then Exit Function
            If a = 0 Then
                DLOOKUP = arr(j, b) '***
            Else
                If Y = a Then DLOOKUP = arr(j, b)
                If a = -1 Then
                    i = i - 1
                    If Y = i Then DLOOKUP = arr(j, b)
                End If
            End If
        End If
    Next
    If a < -1 Then DLOOKUP = i
End Function

YZC51

DLOOKUP函数应用举例
找到上一次录入的里程表数相减然后写到数据库中.rar (65.63 KB, 下载次数: 67)

2019-2-11 20:38 上传

点击文件名下载附件

YZC51

查找函数
Function DLOOKUP4(X, Z, M, Optional a = 1, Optional b = 5) 'a 为查询第1个,其它为最后一个
Dim L, M1, N, Y
'  On Error Resume Next
   arr = M.Parent.UsedRange
    If X <> "燃油费" Then DLOOKUP4 = 0: Exit Function
    Y = UBound(arr)
    If a = 1 Then
        L = 2: M1 = Y: N = 1
    Else
        L = Y: M1 = 2: N = -1
    End If
    For j = L To M1 Step N
        If Len(arr(j, 3)) = 0 Then
        Else
            If arr(j, 3) = X And arr(j, 4) = Z Then DLOOKUP4 = arr(j, b): Exit Function
        End If
    Next
End Function

YZC51

通用的
Function DLOOKUP5(X, Y, M, Optional X1 = 1, Optional Y1 = 0, Optional a = 1, Optional b = 3) 'a 为查询第1个,其它为最后一个
Dim L, M1, N, Z
'  On Error Resume Next
    arr = M.Parent.UsedRange
    Z = UBound(arr)
    If a = 1 Then
        L = 2: M1 = Z: N = 1
    Else
        L = Z: M1 = 2: N = -1
    End If
    For j = L To M1 Step N
        If Len(arr(j, X1)) = 0 Then
        Else
            If Y1 = 0 Then Y2 = "": Y = "" Else Y2 = arr(j, Y1)
            If arr(j, X1) = X And Y2 = Y Then DLOOKUP5 = arr(j, b): Exit Function
        End If
    Next
End Function

YZC51

通用的双条件查询函数说明：
1、X1 设定X 位于第几列；
2、Y1 设定Y 位于第几列，Y1 等于0时，为单条件查询，只查询X的结果；
3、a 为1查询第1个,其它为最后一个；
4、b 设定结果位于第几列。