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

YZC51

lhsh36183 发表于 2019-8-13 17:54
请问有用2003版本做的吗？

应您要求现在上传2003版的文件

YZC51

原创-转码
Public Function zm(t)
'ɪ'nɪʃəlaɪz
  If Len(t) = 0 Then zm = "": Exit Function
  If InStr(t, "&#") Then
    V = Split(t, "&#")
    For i = 1 To UBound(V)
      m = m & ChrW(Left(V(i), 3)) & Mid(V(i), 5)
    Next
    m = V(0) & m
  Else
    m = t
  End If
  zm = "[" & m & "]"
End Function

YZC51

图形聚光灯-通用版
图形聚光灯-无中文.rar (15.65 KB, 下载次数: 304)

2019-8-25 20:00 上传

点击文件名下载附件

YZC51

转码优化
Public Function zm(t)
  Dim V, T1, m
  'ɪ'nɪʃəlaɪz
  If Len(t) = 0 Then zm = "": Exit Function
  If InStr(t, "&#") Then
    V = Split(t, "&#")
    For i = 1 To UBound(V)
      T1 = Split(V(i), ";")(0)
      m = m & ChrW(T1) & Mid(V(i), Len(T1) + 2)
    Next
    m = V(0) & m
  Else
    m = t
  End If
  zm = m
End Function

YZC51

英语单词VBA等等
英语单词VBA.rar (137.73 KB, 下载次数: 221)

2019-8-25 20:58 上传

点击文件名下载附件

YZC51

活动单元格按序跳转
http://club.excelhome.net/thread-1495826-4-1.html
活动单元格按序跳转.rar (16.24 KB, 下载次数: 71)

2019-8-26 10:43 上传

点击文件名下载附件

YZC51

'当前单元格高亮
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '当前单元格高亮
   Dim JGD As Shape, Tr, Tc, TL, Tt, Tw, Th, Col
   If Target.CountLarge > 1 Then Exit Sub
   Tr = Target.Row: Tc = Target.Column: TL = Target.Left
   Tt = Target.Top: Tw = Target.Width: Th = Target.Height
   On Error Resume Next
   ActiveSheet.Shapes("yuan").Delete         '删除特定名称的图形
   With ActiveSheet.Shapes.AddShape(msoShapeRectangle, TL, Tt, Tw, Th)
       .Line.Visible = 1 'msoFalse           '设置为无轮廓
       .Fill.Visible = msoTrue               '设置填充（fill）颜色，如果=msofalse，则为无颜色填充
       .Fill.ForeColor.RGB = RGB(0, 255, 0)  '设置颜色
       .Fill.Transparency = 0.6              '设置透明度，数字愈大透明度越高
       .Name = "yuan"
   End With
End Sub

YZC51

'当前单元格高亮
当前单元格高亮和聚光灯-V2.2.rar (26.88 KB, 下载次数: 276)

2019-8-27 10:11 上传

点击文件名下载附件

YZC51

Public Function 时间戳()
'  时间戳 = DateDiff("s", 25569, Now - 1 / 3) '时间戳10
'  时间戳 = DateDiff("s", "01/01/1970", Now - 1 / 3) '时间戳10
' 时间戳 = DateDiff("s", "01/01/1970 08:00:00", Now) '时间戳10
   时间戳 = (Now - 25569 - 1 / 3) * 86400
'"时间戳13：" & Int(((Date - 25569 - 1 / 3) * 86400 + Timer) * 1000)
End Function

YZC51

'//本程序参考 兰色幻想 老师的 Wlookup 函数制作。在此致谢！2019-09-08 05:23:13

模拟微软最新 Xlookup 函数

Function Xlookup(v, vY, vh, Optional m = 0, Optional n = 1) '匹配未完成
Dim arr, arr1, arr2()
Dim k As Integer
On Error Resume Next
If Len(v) = 0 Then v = 0
arr = vY
arr1 = vh
    If UBound(arr1) = 1 Then
        arr1 = Application.Transpose(arr1)
        arr = Application.Transpose(arr)
    End If
    ReDim arr2(1 To 1)
    For x = 1 To UBound(arr1)
        If m = 2 Then
            flg = arr(x, 1) Like v     '通配符匹配
        ElseIf m = 3 Then
            flg = InStr(arr(x, 1), v)  '包含匹配
        Else
            flg = (arr(x, 1) = v)      '精确匹配
        End If
        If flg And n = 1 Then
            If UBound(arr1, 2) > 1 Then
                Xlookup = arr1(x, 1)
                With Application.ThisCell
                    For j = 1 To UBound(arr1, 2) '自动填充
                        If .Offset(, j) = "" Then s = Null Else s = "*"
                            .Offset(, j).Replace s, arr1(x, j + 1)
                    Next j
                End With
            End If
            Xlookup = arr1(x, 1)
            Exit Function
        Else
            If arr(x, 1) = v Then
                k = k + 1
                ReDim Preserve arr2(1 To k)
                arr2(k) = arr1(x, 1)
            End If
        End If
    Next x
    If Abs(m) = 1 Then
        Xlookup = JS(v, vY, vh, m)
    Else
        If n = 0 Then Xlookup = Join(arr2, ",")
        If n < 0 Then Xlookup = arr2(k)
        If n > 0 Then Xlookup = arr2(n)
    End If
End Function

Function JS(J1, R1, R2, m) '取上下接近值
Dim Jarr1, Jarr2
Dim x
    Jarr1 = R1
    Jarr2 = R2
    For x = 1 To UBound(Jarr1)
        If x + 1 > UBound(Jarr1) Then
            JS = Jarr2(x, 1)
            Exit Function
        ElseIf J1 >= Jarr1(x, 1) And J1 < Jarr1(x + 1, 1) Then
            If m = -1 Then JS = Jarr2(x, 1) Else JS = Jarr2(x + 1, 1)
            Exit Function
        End If
    Next x
End Function