有没有办法让filter函数多一个参数

Filter(inputstrings,value[,include[,compare]],添加参数)

添加的参数是让filter函数能够左起匹配，右起匹配和不定起始位置匹配

左起匹配：abc，cab，cabd是数组A的元素，当value是ab时，返回值为abc
右起匹配：返回值为cab
不定起始位置匹配：返回值为abc，cab，cabd

filter函数本身就是不定起始位置，我希望能够对起始位置加以限制，怎么实现？

20 个解决方案

#1

Filter是String类的“内置”函数，既然这个函数的某些方面的“细节”与你的要求不相符，
那你只有自己写一个“按你的规则来做”的函数了。

要用“别人的函数”，那能做什么、按什么规则来做，那就是别人说了算；
如果没有完全符合你的要求的现成的函数接口，就要自己去实现。

#2

我自己写了个函数不知道对不对，请大神检查（爪机打字）
-------
Private Function TArr(OArr() as string, InputTxt as string, Optional ContTF as boolean=True, Optional Index as integer=0)

Select Case  Index
    Case 0
        i=-1
        j=-1
        Do While i<=UBound(OArr)
            i=i+1
            If ContTF=True And InStr(OArr(i),InputTxt)=1 Then
                     j=j+1
                    Redim Preserve TArr(j)
                    TArr(j)=OArr(i)
            End If
            If ContTF=False And InStr(OArr(i),InputTxt)<>1 Then
                     j=j+1
                    Redim Preserve TArr(j)
                    TArr(j)=OArr(i)
            End If
         Loop
    Case 1
        i=-1
        j=-1
        Do While i<=UBound(OArr)
            i=i+1
            If ContTF=True And InStrRev(OArr(i),InputTxt)=Len(OArr(i))-Len(InputTxt)+1 Then
                     j=j+1
                    Redim Preserve TArr(j)
                    TArr(j)=OArr(i)
            End If
            If ContTF=False And  InStrRev(OArr(i),InputTxt)<>Len(OArr(i))-Len(InputTxt)+1 Then
                     j=j+1
                    Redim Preserve TArr(j)
                    TArr(j)=OArr(i)
            End If
        Loop
    Case 2
        TArr()=Filter(OArr(),InputTxt,ContTF)
End Select

End Function

#3

Index = 0　：左起匹配；
Index = 1　：右起匹配；
Index = 2　：无限制。
对吧？

我看了一下，“目的”倒是算是达到了。
只是楼主的代码，运行效率恐怕有点低吧！

#4

能帮忙优化吗？除了设置变量代替Len函数，InStr函数等？
谢谢啦

#5

首先，从流程上说，你那样的代码在执行过程中，就反复执行了一些不必要的“逻辑操作”。

If (Index = 2) Then
   TArr() = Filter(OArr(), InputTxt, ContTF)
Else
   i = -1
   j = -1
   'If (ContTF = True) Then
   If ContTF Then
      If (Index = 0) Then
         Do While  .......
            .........
         Loop
      Else
         Do While  .......
            .........
         Loop
      End If
   Else
      If (Index = 0) Then
         Do While  .......
            .........
         Loop
      Else
         Do While  .......
            .........
         Loop
      End If
   End If
End If

按我这个流程结构，在循环中，只会执行一个“单条件”的If语句。
而你在2楼的代码中，循环中执行2个“双条件”的If语句、多执行两次 And逻辑运算。

#6

Private Sub Form_Load()
Dim aa() As String, bb() As String
Open App.Path & "\Test.txt" For Input As #1
aa = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
Close #1
bb = TArr(aa, "ab", True, 0)
Text1.Text = Join(bb, vbCrLf)
End Sub


Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
Dim i As Integer
Dim j As Integer
Dim l As Integer

l = Len(InputTXT)

If (StartPos = 2) Then
   TArr() = Filter(OArr(), InputTXT, CTF)
   
Else

   i = -1
   j = -1
   
   If CTF Then
      If (StartPos = 0) Then
         Do While i <= UBound(OArr)
            i = i + 1
            If InStr(OArr(i), InputTXT) = 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr)
            If InStr(OArr(i), InputTXT) <> 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      End If
   Else
      If (StartPos = 1) Then
         Do While i <= UBound(OArr)
            If InStrRev(OArr(i), InputTXT) = Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr)
            If InStrRev(OArr(i), InputTXT) <> Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      End If
   End If
End If


End Function

总是出现下图情况

然后把TArr（）的括号去掉，又出现这种情况
有没有办法让filter函数多一个参数

怎么改正？

#7

Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
改为
Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As Variant
？

#8

这还不是你们没有良好的编程习惯生成的。

函数开头，定义一个字符串数组：
Dim aBuff() As String
然后，函数过程中的代码，所有用 TArr的地方，全部换成 aBuff 。

在函数结束返回之前（End Function之前）：
TArr = aBuff

这样就什么事都没有了。
有没有办法让filter函数多一个参数

在 If (StartPos = 2) Then 这儿，aBuff应该是不要带括号的。
aBuff = Filter(OArr(), InputTXT, CTF)

#9

引用 7 楼 zhao4zhong1 的回复:

Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
改为
Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As Variant
？

最BS你这种“充分利用 Variant ”的人。
有没有办法让filter函数多一个参数

#10

#11

楼主，你仔细对照一下6楼和2楼的代码，我觉得你的逻辑似乎搞错了。
有没有办法让filter函数多一个参数

#12

Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
Dim i As Integer
Dim j As Integer
Dim l As Integer
Dim aBuff() As String

l = Len(InputTXT)

If (StartPos = 2) Then
   aBuff = Filter(OArr(), InputTXT, CTF)
   
Else

   i = -1
   j = -1
   
   If CTF Then
      If (StartPos = 0) Then
         Do While i <= UBound(OArr) - 1
            i = i + 1
            If InStr(OArr(i), InputTXT) = 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr) - 1
            i = i + 1
            If InStrRev(OArr(i), InputTXT) = Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      End If
   Else
      If (StartPos = 0) Then
         Do While i <= UBound(OArr) - 1
            i = i + 1
                        If InStr(OArr(i), InputTXT) <> 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr) - 1
            i = i + 1
            If InStrRev(OArr(i), InputTXT) <> Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      End If
   End If
End If

TArr = aBuff

End Function

测试成功，首先要感谢@Chen8013无私的指导，才能写出这个函数，也感谢@zhao4zhong1的指点
另外说一点，如果有人能够给出更优的结果，请不吝指教。

#13

引用 11 楼 Chen8013 的回复:

楼主，你仔细对照一下6楼和2楼的代码，我觉得你的逻辑似乎搞错了。

运行的时候发现了，已经改了过来，不过还是谢谢提醒

#14

'增强版Filter函数
'-----------------------------------------------------
'添加匹配起始位置参数StartPos
'StartPos=0，从数组元素左侧起匹配
'StartPos=1，从数组元素右侧起匹配
'StartPos=2，不限定匹配的起始位置
'-----------------------------------------------------
'添加是否启动大小写匹配参数LU,默认False,即不启动大小写匹配

#15

看看我的方式：


Private Sub Command1_Click()

Dim Sz
Sz = Split("abc,cab,cabd", ",")
Dim Sz2
Sz2 = Filter(Sz, "ab")
MsgBox "原始方式结果：" & vbCrLf & Join(Sz2, vbCrLf)

Dim Rsz, C As Long
Rsz = Filter2(Sz, "ab", C)
MsgBox "任意位置匹配数据量" & C & vbCrLf & Join(Rsz, vbCrLf)

Rsz = Filter2(Sz, "ab*", C)
MsgBox "左匹配 数据量" & C & vbCrLf & Join(Rsz, vbCrLf)
Rsz = Filter2(Sz, "*ab", C)
MsgBox "右匹配 数据量" & C & vbCrLf & Join(Rsz, vbCrLf)
End Sub
Function Filter2(Sz, FiterVal, Optional C As Long)
Dim Ub As Long, I As Long, Sz2
Ub = UBound(Sz)
If InStr(FiterVal, "*") = 0 Then
    C = Ub + 1
    Sz2 = Filter(Sz, FiterVal)
Else
    C = 0
    ReDim Sz2(Ub)
    For I = 0 To UBound(Sz)
        If Sz(I) Like FiterVal Then
            Sz2(C) = Sz(I)
            C = C + 1
        End If
    Next
    If C > 0 Then
        ReDim Preserve Sz2(C - 1)
    Else
        Erase Sz2
    End If
End If
    Filter2 = Sz2
End Function

#16

2种方式，一种：

Function Filter2(Sz, FiterVal, Optional C As Long)
Dim Ub As Long, I As Long, Sz2
Ub = UBound(Sz)
If InStr(FiterVal, "*") = 0 Then
    Sz2 = Filter(Sz, FiterVal)
    C = UBound(Sz2) + 1
Else
    C = 0
    ReDim Sz2(Ub)
    For I = 0 To Ub
        If Sz(I) Like FiterVal Then
            Sz2(C) = Sz(I)
            C = C + 1
        End If
    Next
    If C > 0 Then
        ReDim Preserve Sz2(C - 1)
    Else
        Sz2 = Filter(Array(""), "a") 'Erase Sz2
    End If
End If
    Filter2 = Sz2
End Function

另一种方式，就是每次用FILTER时一定要加上*，比如：*ab,ab*
如果不指定前后位置就要用*ab*

Function Filter3(Sz, FiterVal, Optional C As Long)
Dim Ub As Long, I As Long, Sz2
Ub = UBound(Sz)
    C = 0
    ReDim Sz2(Ub)
    For I = 0 To Ub
        If Sz(I) Like FiterVal Then
            Sz2(C) = Sz(I)
            C = C + 1
        End If
    Next
    If C > 0 Then
        ReDim Preserve Sz2(C - 1)
    Else
        Sz2 = Filter(Array(""), "a") 'Erase Sz2
    End If
    Filter3 = Sz2
End Function

#17

楼上的，你把别人的一项重要需求：匹配包含／匹配排除给搞掉了！
有没有办法让filter函数多一个参数

#18

'增强版Filter函数  
'-----------------------------------------------------  
'添加匹配起始位置参数StartPos  
'StartPos=0，从数组元素左侧起匹配  
'StartPos=1，从数组元素右侧起匹配  
'StartPos=2，不限定匹配的起始位置  
'-----------------------------------------------------  
'添加是否启动大小写匹配参数LU,默认False,即不启动大小写匹配  
  
Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, _  
Optional StartPos As Integer = 0, Optional LU As Boolean = False) As String()  
  
Dim i As Long  
Dim j As Long  
Dim l As Integer  
Dim ltxt As String  
Dim aBuff() As String  
  
l = Len(InputTXT)  
ltxt = LCase(InputTXT)  
i = -1  
j = -1  
  
If (LU = True) Then  
  
    If CTF Then  
      
        If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) = 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(OArr(i), InputTXT) = Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) <> 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
          
    Else  
        If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) <> 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(OArr(i), InputTXT) <> Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) = 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
          
    End If  
  
Else  
  
    If CTF Then  
      
        If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) = 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(LCase(OArr(i)), ltxt) = Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) <> 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
      
    Else  
      
            If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) <> 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(LCase(OArr(i)), ltxt) <> Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) = 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
      
    End If  
      
End If  
  
TArr = aBuff  
End Function

#19

仅供参考，尽管不是VB6：

#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>

//摘自《代码之美》
//match2(regexp,text)
// 字符     含义
// .        匹配任意的单个字符
// ^        匹配输入字符串的开头
// $        匹配输入字符串的结尾
// *        匹配前一个字符的零个或者多个出现
int matchhere(char *regexp, char *text);
int matchstar(int c, char *regexp, char *text) {// matchstar: search for c*regexp at beginning of text
   do {// a * matches zero or more instances
       if (matchhere(regexp, text)) return 1;
   } while (*text != '\0' && (*text++ == c || c == '.'));
   return 0;
}
int matchhere(char *regexp, char *text) {// matchhere: search for regexp at beginning of text
   if (regexp[0] == '\0') return 1;
   if (regexp[1] == '*') return matchstar(regexp[0], regexp+2, text);
   if (regexp[0] == '$' && regexp[1] == '\0') return *text == '\0';
   if (*text!='\0' && (regexp[0]=='.' || regexp[0]==*text)) return matchhere(regexp+1, text+1);
   return 0;
}
int match2(char *regexp, char *text) {// match: search for regexp anywhere in text
    if (regexp[0] == '^') return matchhere(regexp+1, text);
    do {// must look even if string is empty
        if (matchhere(regexp, text)) return 1;
    } while (*text++ != '\0');
    return 0;
}

//match1(regexp,text)
// 字符     含义
// ?        匹配任意的单个字符
// *        匹配零个或者多个字符
int match_imp(const char *d,int dcur,const char *s,int scur) {
    if(!d[dcur]) return (!s[scur])?1:0;
    if (d[dcur]=='?') return match_imp(d,dcur+1,s,scur+1);
    else if(d[dcur]=='*') {
        do {
            if (match_imp(d,dcur+1,s,scur)) return 1;
        } while (s[scur++]);
        return 0;
    } else return (tolower(d[dcur])==tolower(s[scur]) && match_imp(d,dcur+1,s,scur+1))?1:0;
}
int match1(char* s1, char* s2) {
    return match_imp(s1,0,s2,0);
}

int main() {
    printf("%d==match1(abc ,abc)\n",match1("abc" ,"abc"));
    printf("%d==match1(a?c ,abc)\n",match1("a?c" ,"abc"));
    printf("%d==match1(a*c ,abc)\n",match1("a*c" ,"abc"));
    printf("-------------------\n");
    printf("%d==match1(abc ,abd)\n",match1("abc" ,"abd"));
    printf("%d==match1(a?c ,abd)\n",match1("a?c" ,"abd"));
    printf("%d==match1(a*c ,abd)\n",match1("a*c" ,"abd"));
    printf("\n");
    printf("%d==match2(abc ,abc)\n",match2("abc" ,"abc"));
    printf("%d==match2(^a  ,abc)\n",match2("^a"  ,"abc"));
    printf("%d==match2(c$  ,abc)\n",match2("c$"  ,"abc"));
    printf("%d==match2(a.c ,abc)\n",match2("a.c" ,"abc"));
    printf("%d==match2(a.*c,abc)\n",match2("a.*c","abc"));
    printf("-------------------\n");
    printf("%d==match2(ABC ,abc)\n",match2("ABC" ,"abc"));
    printf("%d==match2(^B  ,abc)\n",match2("^B"  ,"abc"));
    printf("%d==match2(A$  ,abc)\n",match2("A$"  ,"abc"));
    printf("%d==match2(a..c,abc)\n",match2("a..c","abc"));
    printf("%d==match2(a.*d,abc)\n",match2("a.*d","abc"));
    return 0;
}
//1==match1(abc ,abc)
//1==match1(a?c ,abc)
//1==match1(a*c ,abc)
//-------------------
//0==match1(abc ,abd)
//0==match1(a?c ,abd)
//0==match1(a*c ,abd)
//
//1==match2(abc ,abc)
//1==match2(^a  ,abc)
//1==match2(c$  ,abc)
//1==match2(a.c ,abc)
//1==match2(a.*c,abc)
//-------------------
//0==match2(ABC ,abc)
//0==match2(^B  ,abc)
//0==match2(A$  ,abc)
//0==match2(a..c,abc)
//0==match2(a.*d,abc)
//

#20

再一次来BS楼上的！

你理解到了楼主的需求吗？
有没有办法让filter函数多一个参数

#1

#2

#3

#4

能帮忙优化吗？除了设置变量代替Len函数，InStr函数等？
谢谢啦

#5

首先，从流程上说，你那样的代码在执行过程中，就反复执行了一些不必要的“逻辑操作”。

If (Index = 2) Then
   TArr() = Filter(OArr(), InputTxt, ContTF)
Else
   i = -1
   j = -1
   'If (ContTF = True) Then
   If ContTF Then
      If (Index = 0) Then
         Do While  .......
            .........
         Loop
      Else
         Do While  .......
            .........
         Loop
      End If
   Else
      If (Index = 0) Then
         Do While  .......
            .........
         Loop
      Else
         Do While  .......
            .........
         Loop
      End If
   End If
End If

按我这个流程结构，在循环中，只会执行一个“单条件”的If语句。
而你在2楼的代码中，循环中执行2个“双条件”的If语句、多执行两次 And逻辑运算。

#6

Private Sub Form_Load()
Dim aa() As String, bb() As String
Open App.Path & "\Test.txt" For Input As #1
aa = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
Close #1
bb = TArr(aa, "ab", True, 0)
Text1.Text = Join(bb, vbCrLf)
End Sub


Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
Dim i As Integer
Dim j As Integer
Dim l As Integer

l = Len(InputTXT)

If (StartPos = 2) Then
   TArr() = Filter(OArr(), InputTXT, CTF)
   
Else

   i = -1
   j = -1
   
   If CTF Then
      If (StartPos = 0) Then
         Do While i <= UBound(OArr)
            i = i + 1
            If InStr(OArr(i), InputTXT) = 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr)
            If InStr(OArr(i), InputTXT) <> 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      End If
   Else
      If (StartPos = 1) Then
         Do While i <= UBound(OArr)
            If InStrRev(OArr(i), InputTXT) = Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr)
            If InStrRev(OArr(i), InputTXT) <> Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve TArr(j)
                TArr(j) = OArr(i)
            End If
         Loop
      End If
   End If
End If


End Function

总是出现下图情况

然后把TArr（）的括号去掉，又出现这种情况
有没有办法让filter函数多一个参数

怎么改正？

#7

#8

在 If (StartPos = 2) Then 这儿，aBuff应该是不要带括号的。
aBuff = Filter(OArr(), InputTXT, CTF)

#9

引用 7 楼 zhao4zhong1 的回复:

Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
改为
Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As Variant
？

最BS你这种“充分利用 Variant ”的人。
有没有办法让filter函数多一个参数

#10

#11

楼主，你仔细对照一下6楼和2楼的代码，我觉得你的逻辑似乎搞错了。
有没有办法让filter函数多一个参数

#12

Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, Optional StartPos As Integer = 0) As String()
Dim i As Integer
Dim j As Integer
Dim l As Integer
Dim aBuff() As String

l = Len(InputTXT)

If (StartPos = 2) Then
   aBuff = Filter(OArr(), InputTXT, CTF)
   
Else

   i = -1
   j = -1
   
   If CTF Then
      If (StartPos = 0) Then
         Do While i <= UBound(OArr) - 1
            i = i + 1
            If InStr(OArr(i), InputTXT) = 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr) - 1
            i = i + 1
            If InStrRev(OArr(i), InputTXT) = Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      End If
   Else
      If (StartPos = 0) Then
         Do While i <= UBound(OArr) - 1
            i = i + 1
                        If InStr(OArr(i), InputTXT) <> 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      Else
         Do While i <= UBound(OArr) - 1
            i = i + 1
            If InStrRev(OArr(i), InputTXT) <> Len(OArr(i)) - l + 1 Then
                j = j + 1
                ReDim Preserve aBuff(j)
                aBuff(j) = OArr(i)
            End If
         Loop
      End If
   End If
End If

TArr = aBuff

End Function

测试成功，首先要感谢@Chen8013无私的指导，才能写出这个函数，也感谢@zhao4zhong1的指点
另外说一点，如果有人能够给出更优的结果，请不吝指教。

#13

引用 11 楼 Chen8013 的回复:

楼主，你仔细对照一下6楼和2楼的代码，我觉得你的逻辑似乎搞错了。

运行的时候发现了，已经改了过来，不过还是谢谢提醒

#14

'增强版Filter函数
'-----------------------------------------------------
'添加匹配起始位置参数StartPos
'StartPos=0，从数组元素左侧起匹配
'StartPos=1，从数组元素右侧起匹配
'StartPos=2，不限定匹配的起始位置
'-----------------------------------------------------
'添加是否启动大小写匹配参数LU,默认False,即不启动大小写匹配

#15

看看我的方式：


Private Sub Command1_Click()

Dim Sz
Sz = Split("abc,cab,cabd", ",")
Dim Sz2
Sz2 = Filter(Sz, "ab")
MsgBox "原始方式结果：" & vbCrLf & Join(Sz2, vbCrLf)

Dim Rsz, C As Long
Rsz = Filter2(Sz, "ab", C)
MsgBox "任意位置匹配数据量" & C & vbCrLf & Join(Rsz, vbCrLf)

Rsz = Filter2(Sz, "ab*", C)
MsgBox "左匹配 数据量" & C & vbCrLf & Join(Rsz, vbCrLf)
Rsz = Filter2(Sz, "*ab", C)
MsgBox "右匹配 数据量" & C & vbCrLf & Join(Rsz, vbCrLf)
End Sub
Function Filter2(Sz, FiterVal, Optional C As Long)
Dim Ub As Long, I As Long, Sz2
Ub = UBound(Sz)
If InStr(FiterVal, "*") = 0 Then
    C = Ub + 1
    Sz2 = Filter(Sz, FiterVal)
Else
    C = 0
    ReDim Sz2(Ub)
    For I = 0 To UBound(Sz)
        If Sz(I) Like FiterVal Then
            Sz2(C) = Sz(I)
            C = C + 1
        End If
    Next
    If C > 0 Then
        ReDim Preserve Sz2(C - 1)
    Else
        Erase Sz2
    End If
End If
    Filter2 = Sz2
End Function

#16

2种方式，一种：

Function Filter2(Sz, FiterVal, Optional C As Long)
Dim Ub As Long, I As Long, Sz2
Ub = UBound(Sz)
If InStr(FiterVal, "*") = 0 Then
    Sz2 = Filter(Sz, FiterVal)
    C = UBound(Sz2) + 1
Else
    C = 0
    ReDim Sz2(Ub)
    For I = 0 To Ub
        If Sz(I) Like FiterVal Then
            Sz2(C) = Sz(I)
            C = C + 1
        End If
    Next
    If C > 0 Then
        ReDim Preserve Sz2(C - 1)
    Else
        Sz2 = Filter(Array(""), "a") 'Erase Sz2
    End If
End If
    Filter2 = Sz2
End Function

另一种方式，就是每次用FILTER时一定要加上*，比如：*ab,ab*
如果不指定前后位置就要用*ab*

Function Filter3(Sz, FiterVal, Optional C As Long)
Dim Ub As Long, I As Long, Sz2
Ub = UBound(Sz)
    C = 0
    ReDim Sz2(Ub)
    For I = 0 To Ub
        If Sz(I) Like FiterVal Then
            Sz2(C) = Sz(I)
            C = C + 1
        End If
    Next
    If C > 0 Then
        ReDim Preserve Sz2(C - 1)
    Else
        Sz2 = Filter(Array(""), "a") 'Erase Sz2
    End If
    Filter3 = Sz2
End Function

#17

楼上的，你把别人的一项重要需求：匹配包含／匹配排除给搞掉了！
有没有办法让filter函数多一个参数

#18

'增强版Filter函数  
'-----------------------------------------------------  
'添加匹配起始位置参数StartPos  
'StartPos=0，从数组元素左侧起匹配  
'StartPos=1，从数组元素右侧起匹配  
'StartPos=2，不限定匹配的起始位置  
'-----------------------------------------------------  
'添加是否启动大小写匹配参数LU,默认False,即不启动大小写匹配  
  
Public Function TArr(OArr() As String, InputTXT As String, Optional CTF As Boolean = True, _  
Optional StartPos As Integer = 0, Optional LU As Boolean = False) As String()  
  
Dim i As Long  
Dim j As Long  
Dim l As Integer  
Dim ltxt As String  
Dim aBuff() As String  
  
l = Len(InputTXT)  
ltxt = LCase(InputTXT)  
i = -1  
j = -1  
  
If (LU = True) Then  
  
    If CTF Then  
      
        If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) = 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(OArr(i), InputTXT) = Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) <> 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
          
    Else  
        If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) <> 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(OArr(i), InputTXT) <> Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(OArr(i), InputTXT) = 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
          
    End If  
  
Else  
  
    If CTF Then  
      
        If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) = 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(LCase(OArr(i)), ltxt) = Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) <> 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
      
    Else  
      
            If StartPos = 0 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) <> 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        ElseIf StartPos = 1 Then  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStrRev(LCase(OArr(i)), ltxt) <> Len(OArr(i)) - l + 1 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        Else  
          
            Do While i <= UBound(OArr) - 1  
                i = i + 1  
                If InStr(LCase(OArr(i)), ltxt) = 0 Then  
                    j = j + 1  
                    ReDim Preserve aBuff(j)  
                    aBuff(j) = OArr(i)  
                End If  
            Loop  
              
        End If  
      
    End If  
      
End If  
  
TArr = aBuff  
End Function

#19

仅供参考，尽管不是VB6：

#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>

//摘自《代码之美》
//match2(regexp,text)
// 字符     含义
// .        匹配任意的单个字符
// ^        匹配输入字符串的开头
// $        匹配输入字符串的结尾
// *        匹配前一个字符的零个或者多个出现
int matchhere(char *regexp, char *text);
int matchstar(int c, char *regexp, char *text) {// matchstar: search for c*regexp at beginning of text
   do {// a * matches zero or more instances
       if (matchhere(regexp, text)) return 1;
   } while (*text != '\0' && (*text++ == c || c == '.'));
   return 0;
}
int matchhere(char *regexp, char *text) {// matchhere: search for regexp at beginning of text
   if (regexp[0] == '\0') return 1;
   if (regexp[1] == '*') return matchstar(regexp[0], regexp+2, text);
   if (regexp[0] == '$' && regexp[1] == '\0') return *text == '\0';
   if (*text!='\0' && (regexp[0]=='.' || regexp[0]==*text)) return matchhere(regexp+1, text+1);
   return 0;
}
int match2(char *regexp, char *text) {// match: search for regexp anywhere in text
    if (regexp[0] == '^') return matchhere(regexp+1, text);
    do {// must look even if string is empty
        if (matchhere(regexp, text)) return 1;
    } while (*text++ != '\0');
    return 0;
}

//match1(regexp,text)
// 字符     含义
// ?        匹配任意的单个字符
// *        匹配零个或者多个字符
int match_imp(const char *d,int dcur,const char *s,int scur) {
    if(!d[dcur]) return (!s[scur])?1:0;
    if (d[dcur]=='?') return match_imp(d,dcur+1,s,scur+1);
    else if(d[dcur]=='*') {
        do {
            if (match_imp(d,dcur+1,s,scur)) return 1;
        } while (s[scur++]);
        return 0;
    } else return (tolower(d[dcur])==tolower(s[scur]) && match_imp(d,dcur+1,s,scur+1))?1:0;
}
int match1(char* s1, char* s2) {
    return match_imp(s1,0,s2,0);
}

int main() {
    printf("%d==match1(abc ,abc)\n",match1("abc" ,"abc"));
    printf("%d==match1(a?c ,abc)\n",match1("a?c" ,"abc"));
    printf("%d==match1(a*c ,abc)\n",match1("a*c" ,"abc"));
    printf("-------------------\n");
    printf("%d==match1(abc ,abd)\n",match1("abc" ,"abd"));
    printf("%d==match1(a?c ,abd)\n",match1("a?c" ,"abd"));
    printf("%d==match1(a*c ,abd)\n",match1("a*c" ,"abd"));
    printf("\n");
    printf("%d==match2(abc ,abc)\n",match2("abc" ,"abc"));
    printf("%d==match2(^a  ,abc)\n",match2("^a"  ,"abc"));
    printf("%d==match2(c$  ,abc)\n",match2("c$"  ,"abc"));
    printf("%d==match2(a.c ,abc)\n",match2("a.c" ,"abc"));
    printf("%d==match2(a.*c,abc)\n",match2("a.*c","abc"));
    printf("-------------------\n");
    printf("%d==match2(ABC ,abc)\n",match2("ABC" ,"abc"));
    printf("%d==match2(^B  ,abc)\n",match2("^B"  ,"abc"));
    printf("%d==match2(A$  ,abc)\n",match2("A$"  ,"abc"));
    printf("%d==match2(a..c,abc)\n",match2("a..c","abc"));
    printf("%d==match2(a.*d,abc)\n",match2("a.*d","abc"));
    return 0;
}
//1==match1(abc ,abc)
//1==match1(a?c ,abc)
//1==match1(a*c ,abc)
//-------------------
//0==match1(abc ,abd)
//0==match1(a?c ,abd)
//0==match1(a*c ,abd)
//
//1==match2(abc ,abc)
//1==match2(^a  ,abc)
//1==match2(c$  ,abc)
//1==match2(a.c ,abc)
//1==match2(a.*c,abc)
//-------------------
//0==match2(ABC ,abc)
//0==match2(^B  ,abc)
//0==match2(A$  ,abc)
//0==match2(a..c,abc)
//0==match2(a.*d,abc)
//

#20

再一次来BS楼上的！

你理解到了楼主的需求吗？
有没有办法让filter函数多一个参数

有没有办法让filter函数多一个参数

20 个解决方案

#1

#2

#3

#4

#5

#6

#7

#8

#9

#10

#11

#12

#13

#14

#15

#16

#17

#18

#19

#20

#1

#2

#3

#4

#5

#6

#7

#8

#9

#10

#11

#12

#13

#14

#15

#16

#17

#18

#19

#20

相关文章