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

zhshbding

比如这样，在同一个单元格里面的

YZC51

zhshbding 发表于 2020-2-8 10:01
比如这样，在同一个单元格里面的

老师好！好像需要用到字典，学生现在对字典不熟悉！等学习下

YZC51

VBA  带小数求余问题
Function ys(x, n)
    a = Int(x)
    b = x - a
    c = a Mod n
    ys = b + c
End Function

YZC51

非原创（在一附件中发现的，不知道是哪位老师的佳作，还请老师见谅！）
Public Function pointxy(t, s) '单元格屏幕坐标
    If s = 0 Then
        pointxy = ActiveWindow.PointsToScreenPixelsX(t.Top)
    Else
        pointxy = ActiveWindow.PointsToScreenPixelsY(t.Top)
    End If
End Function

zhshbding

当需要匹配的数据几十万行时，vlookup函数运行很卡，用VBA字典可以解决。字典法的dlookup函数，不足之处是只能在同一个工作表里面使用。代码如下：

1. Sub dlookup()
   
2.     Dim i&, arr1(), arr2(), krr(), temp(), t&, s&, arr(), k&
   
3.     On Error Resume Next
   
4.     Set Rg = Application.InputBox("请选择key列", Title:="提示", Type:=8) '返回数值
   
5.     t = Rg.Column  '取列标
   
6.     p = Cells(Rows.count, t).End(xlUp).Row '最后一个单元格行标
   
7.     arr1 = ActiveSheet.Cells(1, t).Resize(p).Value
   
8.     Set Rg = Application.InputBox("请选择item列", Title:="提示", Type:=8) '返回数值
   
9.     u = Rg.Column  '取列标
   
10.     v = Cells(Rows.count, t).End(xlUp).Row '最后一个单元格行标
    
11.     arr2 = ActiveSheet.Cells(1, u).Resize(v).Value
    
12.     ReDim krr(1 To UBound(arr1), 1)
    
13.     For s = 1 To UBound(arr1)
    
14.         krr(s, 0) = arr1(s, 1)
    
15.         krr(s, 1) = arr2(s, 1)
    
16.     Next
    
17.     Set dic = CreateObject("scripting.dictionary")
    
18.     For i = 1 To UBound(krr)
    
19.         dic(krr(i, 0) & "") = krr(i, 1)
    
20.     Next
    
21.     Set wg = Application.InputBox("选择被匹配一列", Title:="提示", Type:=8)
    
22.     '返回数据一列
    
23.     w = wg.Column '取列标
    
24.     p = Cells(Rows.count, w).End(xlUp).Row '最后一个单元格行标
    
25.     ReDim temp(1 To p, 1)
    
26.     temp = Range(Cells(1, w), Cells(p, w))
    
27.     ReDim arr(1 To UBound(temp), 1 To 1)
    
28.     For k = 1 To UBound(temp)
    
29.         arr(k, 1) = dic(temp(k, 1))
    
30.     Next
    
31.     Set ng = Application.InputBox("返回数据一列", Title:="提示", Type:=8)
    
32.     '返回数据一列
    
33.     n = ng.Column
    
34.     Cells(1, n).Resize(UBound(arr), 1) = arr
    
35.     Set dic = Nothing
    
36.     Erase arr1
    
37.     Erase arr2
    
38.     Erase krr
    
39.     Erase arr
    
40.     Erase temp
    
41. End Sub

复制代码

YZC51

zhshbding 发表于 2020-2-9 11:32
当需要匹配的数据几十万行时，vlookup函数运行很卡，用VBA字典可以解决。字典法的dlookup函数，不足之处是 ...

谢谢老师提供代码！

YZC51

企业员工情况登记表-简版
附行 政区域代码
企业员工情况登记表-简版.rar (164.21 KB, 下载次数: 30)

2020-2-10 20:21 上传

点击文件名下载附件

YZC51

‘单元格内年龄自动加一岁
Public Function jsnl(t$)
    Dim UB
    UB = Len(t) - Len(Replace(t, "岁", ""))
    For i = 1 To UB
        For k = 1 To 150
            t = Replace(t, " " & k & "岁", " " & k + 1 & "|")
        Next
    Next
    jsnl = Replace(t, "|", "岁")
End Function

YZC51

分列中英文
Option Compare Text '设定字符比较的格式

Function PY(t, x)
    For i = 1 To Len(t)
        If x = 1 Then mm = Mid(t, i, 1) >= "吖" Else mm = Mid(t, i, 1) < "吖"
        If mm Or Mid(t, i, 1) = "，" Then
            PY = PY & Mid(t, i, 1)
        End If
    Next
End Function

YZC51

字典列去重
Function getKuanhao(inputText, x)
    Dim w
'    w = Worksheets("会员信息").[a1].CurrentRegion
    w = Worksheets("会员信息").Cells(1, x).CurrentRegion
    Dim i
    Dim k
    i = 2
    Dim myDic As Object
    Set myDic = CreateObject("scripting.dictionary")
     For i = 2 To UBound(w)
        If Not myDic.exists(w(i, x)) And InStr(w(i, x), inputText) > 0 Then
            myDic.Add w(i, x), " "
        End If
     Next
    If myDic.Count = 0 Then    '如果字典为空不处理的话 后面会出现数据类型不匹配
   '     myDic.Add "没有这个款号", ""
        myDic.Add " ", ""
   Exit Function
    End If
    getKuanhao = Application.Transpose(myDic.keys)
End Function