VBA自定义函数应用

ctp_119

本人第一次发帖，首先给大家来一个非常实用的自定义函数，尤其是用excel来做仓库账的朋友。
     仓库结存处要有材料名称，这个名称要唯一，且是从上期结存处和本期发生处提取唯一物料名称值，这个函数就是起这个作用的。
Option Base 1

'改进后的改进    (这个是普通函数,不是数组函数)
'可以对两个区域取唯一值
'应该是终极版了吧???!!!!!!!!
'虽然weiyi7和weiyi5功能一样,但是速度远不及weiyi5快!!!!但是作为一种方法可以探究!!!
Function weiyi5(rng1 As Range, rng2 As Range, j As Integer)
Dim wys As Integer
'定义一个变量为range对象,另一个变量为collectin对象
Dim mycell As Range, unique As New Collection   '隐性声明unique变量为collection对象
'重新计算,即刷新
Application.Calculate
'若有错误,接着运行下一行.
On Error Resume Next
'把唯一的元素添加到collection中.
For Each mycell In rng1
    If IsEmpty(mycell) Then GoTo 100
    '如果添加的是重复值,则会产生错误,但是前面又用了on error resume next.
    unique.Add mycell.Value, CStr(mycell.Value)
100:
Next mycell
For Each mycl In rng2
    If IsEmpty(mycl) Then GoTo 10
    unique.Add mycl.Value, CStr(mycl.Value)
10:
Next mycl
On Error GoTo 0
wys = unique.Count
For i = 1 To wys
    If i = j Then
    weiyi5 = unique(i)
    End If
Next i       '为什么要减"1",因为next i 加了"1",所以要减回去!!!!
If j > i - 1 Then weiyi5 = ""
End Function

'改进后的改进    (这个是普通函数,不是数组函数)
'可以对两个区域取唯一值
Function weiyi4(rng1 As Range, rng2 As Range, j As Integer)
'定义一个动态数组a
Dim a()
'定义一个变量(唯一数)为整型变量
Dim wys As Integer
'定义一个变量为range对象,另一个变量为collectin对象
Dim mycell As Range, unique As New Collection
'重新计算,即刷新
Application.Calculate
'若有错误,接着运行下一行.
On Error Resume Next
'把唯一的元素添加到collection中.
For Each mycell In rng1
    If IsEmpty(mycell) Then GoTo 100
    unique.Add mycell.Value, CStr(mycell.Value)
100:
Next mycell
For Each mycl In rng2
    If IsEmpty(mycl) Then GoTo 10
    unique.Add mycl.Value, CStr(mycl.Value)
10:
Next mycl
On Error GoTo 0
wys = unique.Count
ReDim a(wys)
For i = 1 To wys
    a(i) = unique(i)
    If i = j Then
    weiyi4 = a(i)
    End If
Next i
End Function

'改进后的改进    (这个是普通函数,不是数组函数)
Function weiyi3(rng As Range, j As Integer)
'定义一个变量(唯一数)为整型变量
Dim wys As Integer
Dim i As Integer
'定义一个变量为range对象,另一个变量为collectin对象
Dim mycell As Range, unique As New Collection
'重新计算,即刷新
Application.Calculate
'若有错误,接着运行下一行.
On Error Resume Next
'把唯一的元素添加到collection中.
For Each mycell In rng
    If IsEmpty(mycell) Then GoTo 100
    unique.Add mycell.Value, CStr(mycell.Value)
100:
Next mycell
On Error GoTo 0
wys = unique.Count
For i = 1 To wys
    If i = j Then
    weiyi3 = unique(i)
    End If
Next i
If j > i - 1 Then weiyi3 = ""
End Function
'改进后的,还是个数组函数
Function weiyi2(rng As Range)
'定义一个动态数组a
Dim a()
'定义一个变量(唯一数)为整型变量
Dim wys As Integer
'定义一个变量为range对象,另一个变量为collectin对象
Dim mycell As Range, unique As New Collection
'重新计算,即刷新
Application.Calculate
'若有错误,接着运行下一行.
On Error Resume Next
'把唯一的元素添加到collection中.
For Each mycell In rng
    unique.Add mycell.Value, CStr(mycell.Value)
Next mycell
On Error GoTo 0
wys = unique.Count
ReDim a(wys)
For i = 1 To wys
    a(i) = unique(i)
Next i
weiyi2 = Application.Transpose(a)
End Function
'原始的,是个数组函数
Function weiyi1(rng As Range)
'定义一个动态数组a
Dim a()
'定义一个变量(唯一数)为整型变量
Dim wys As Integer
'定义一个变量为range对象,另一个变量为collectin对象
Dim mycell As Range, unique As New Collection
'重新计算,即刷新
Application.Calculate
'若有错误,接着运行下一行.
On Error Resume Next
'把唯一的元素添加到collection中.
For Each mycell In rng
    unique.Add mycell.Value, CStr(mycell.Value)
Next mycell
On Error GoTo 0
wys = unique.Count
ReDim a(wys)
Dim rws As Integer
Dim i As Integer
Dim j As Integer
j = wys
rws = rng.Rows.Count
Do While rws > 0
    For i = 1 To rws - 1
        If rng(rws) = rng(rws - i) Then GoTo 100
    Next i
    a(j) = rng(rws)
    j = j - 1
100:
    rws = rws - 1
Loop
weiyi1 = Application.Transpose(a)
End Function

Function weiyi6(rng As Range, x As Integer)
Dim hs As Integer
Dim data As Variant
Dim i As Integer
Dim j As Integer
hs = rng.Rows.Count
For i = 1 To hs
    m = rng(i)
   Set data = rng.Range("a" & i).Resize(hs + 1 - i)
   If Application.WorksheetFunction.CountIf(data, m) = 1 Then
        j = j + 1
        If x = j Then
        weiyi6 = m
        End If
    End If
Next i
End Function
'这是一个全新的算法
'比较这两种核心算法,哪种更好理解和速度更快!!!!!!!?
Function weiyi7(rng1 As Range, rng2 As Range, x As Integer)
Dim hs1 As Integer
Dim data1 As Variant
Dim i As Integer
Dim j As Integer
hs1 = rng1.Rows.Count
For i = 1 To hs1
    q = rng1(i)
   Set data1 = rng1.Range("a" & i).Resize(hs1 + 1 - i)      '注意"a"是一个相对量,表示rng1的第一列.
   If Application.WorksheetFunction.CountIf(data1, q) = 1 Then
        j = j + 1
        If x = j Then
        weiyi7 = q
        End If
    End If
Next i
Dim hs2 As Integer
Dim data2 As Variant
Dim m As Integer
hs2 = rng2.Rows.Count
For m = 1 To hs2
    p = rng2(m)
    Set data2 = rng2.Range("a" & m).Resize(hs2 + 1 - m)
    If Application.WorksheetFunction.CountIf(rng1, p) + Application.WorksheetFunction.CountIf(data2, p) = 1 Then
        j = j + 1
        If x = j Then
        weiyi7 = p
        End If
    End If
Next m
If x > j - 1 Then weiyi7 = ""     '这句主要是把"过界"的零去掉.
End Function
          通过这个函数的开发和应用，你一定收获不小！！！开发的一个历程。用不同的方法来解决同一个问题，同时比较方法的好坏！！！

一指禅

谢谢分享

ctp_119

只是明白的人很少，很是遗憾！！！

ctp_119

总算有人关注过。。。
本人还有一些好东西，想和大家分享。若有人关注，我会一一发上来。

一指禅

谢谢分享！希望楼主发上来！！！

热浪2006

原帖由 ctp_119 于 2010-4-20 15:30 发表
只是明白的人很少，很是遗憾！！！

首发受挫，要坚强！

ctp_119

是呀，要坚持！！！今天我再发个我对if函数的理解和应用扩展。
希望能给大家启示。

ctp_119

'提取数字
Function 提取数字(a As String)
Dim i As Integer, j As Integer
Dim s As String
For j = 1 To Len(a)
    For i = 0 To 9
    If Mid(a, j, 1) = i Then
    s = s & i
    End If
    Next i
Next j
提取数字 = Val(s)
End Function
'提取数字
Function tiqushuzi(a As String)
Dim i As Integer
Dim p As Integer
Dim z As String
Dim s As String
p = Len(a)
For i = 1 To p
    z = Mid(a, i, 1)
    If Asc(z) >= 48 And Asc(z) <= 57 Then s = s + z
Next
tiqushuzi = Val(s)
End Function
'提取字符新方法
Function tqzf(str As String)
Dim i As Integer
tqzf = str
s = Len(str)
For i = 0 To Application.WorksheetFunction.Max(s, 9)
    tqzf = Replace(tqzf, i, "")
Next
End Function
'提取数字的新方法
Function tqsz(mystr As String)
Dim i As Integer
Dim str As String
For i = 1 To Len(mystr)
    If Mid(mystr, i, 1) = "0" Then str = str + Mid(mystr, i, 1)
    If Val(Mid(mystr, i, 1)) > 0 Then
    str = str + Mid(mystr, i, 1)
    End If
Next i
tqsz = Val(str)
End Function

aidixiao

好东西，感谢楼主分享。

一指禅

支持楼主，俺也凑一个！
Function TQSZ(Srg As String)

    Dim i As Integer
    Dim s, MyString As String
    Dim Bol As Boolean
   
    For i = 1 To Len(Srg)
         s = Mid(Srg, i, 1)
              Bol = s Like "[0-9.]"
        If Bol Then MyString = MyString & s
    Next
   
    TQSZ = MyString
     
End Function

将  Bol = s Like "[0-9.]"修改为
Bol = s Like "[0-9.+-/\*]"
便可以提取公式表达式！

[ 本帖最后由 一指禅 于 2010-4-29 09:16 编辑 ]