[已解决]按指定条件提取字符

lichuanboy44

详见下图，谢谢高手，用vba解答

最佳答案

月排行榜 / 总排行榜

爱疯

2016-5-12 15:45

Sub Click()
    Dim A, i, j, x, v1, v2, b1, b2
    i = Range("a65536").End(3).Row
    Range("c2:c" & i).ClearContents
    A = Range("a1:c" & i)
    j = 1

    For i = UBound(A) To 2 Step -1
        x = A(i, 2)
        b1 = x Like "*a*" And x Like "*c*"
        b2 = x Like "*b*" And x Like "*f*"

        If b1 Then v1 = x    '条件1
        If i Mod 2 = 0 Then If b2 Then v2 = x    '条件2
        If b1 = False And b2 = False Then j = j + 1: A(j, 3) = x    '条件3
    Next i

    [k1].CurrentRegion.ClearContents
    [k1].Resize(UBound(A), UBound(A, 2)) = A
    Cells(Range("m65536").End(3).Row + 1, "m") = v2
    Cells(Range("m65536").End(3).Row + 1, "m") = v1
End Sub


这样可以吗

跳转到最佳答案楼层

望帝春心

没看懂

爱疯

1）为什么是"abcf"，不是"abcd"？强迫症表示会一直思考这个问题。。。。。。。

2）第3个条件真绕口，没明白是啥意思

lichuanboy44

望帝春心 发表于 2016-5-12 11:25
没看懂

正因为用if还有字典等均达不到要求，逻辑关系有点绕来绕去的，但要得到的结果是清楚的，我才求助。

上清宫主

确实，真心的看不懂
有一招：不管要求是怎么校的，反正就只有四个字符，其所有的排列就仅那么点，逐一罗列也很方便，对不？

lichuanboy44

爱疯 发表于 2016-5-12 11:28
1）为什么是"abcf"，不是"abcd"？强迫症表示会一直思考这个问题。。。。。。。

2）第3个条件真绕口，没明 ...

没用b的原因，是本来有点绕，b 和 d看起眼花，故用f替换，abcd仅是模拟的，其它字符都行。
第三个条件理解是。一是不符合仅含a且c的，如abc、fba之类的。二是不符合仅含b且f的, 如abf、bfc
另外，本题正因为有点绕，才求助，但结果是清楚的。
有时网上复杂的数组函数也让人觉得十分费脑。

lichuanboy44

上清宫主 发表于 2016-5-12 11:38
确实，真心的看不懂
有一招：不管要求是怎么校的，反正就只有四个字符，其所有的排列就仅那么点，逐一罗列 ...

谢谢你的建议

爱疯

好像理解了。声明一个结果数组，倒序遍历一次应该可以了吧，主要是怎么写条件表达式，只有下午再看了。

pengyx

B列总共就64个结果，abcf的组合就64，一个个比较不就行了？？

lichuanboy44

    终于绕出了结果，如果有符合条件的存入字典后，那么就将一变量p1人为赋值，第二个类似的就不能存入字典了。
    此题关键是如果第一次将acc存入字典，其后的cca  cac  aac  aca caa等类似组合都不能存入字典了。如果值完全相等，则直接可用not d.exists判定，关键是类似组合，所以也不是将所有组合完全排出来比对的问题。
    只觉得程序有点不简洁，因为每个if里符合条件的，除共同进行d(s2) = ""语句外，还有其它一模一样的其它判断操作，如果用function则语句又不多。此题也不是无中生有的问题。
     本人水平不高，表述不好，在此谢谢各位高手指点与批评。

1. Sub tyy()
   
2.   ar = [A1].CurrentRegion
   
3.   Set d = CreateObject("scripting.dictionary")
   
4.   n = UBound(ar)
   
5.   For i = 2 To n - 1
   
6.     s1 = ar(i, 1): s2 = ar(i, 2)
   
7.     nb = InStr(s2, "b"): nf = InStr(s2, "f")
   
8.     na = InStr(s2, "a"): nc = InStr(s2, "c")
   
9.     If nb = 0 And nf = 0 And na <> 0 And nc <> 0 Then '仅含a且c
   
10.        If p1 = 0 And Not d.exists(s2) Then
    
11.           d(s2) = ""
    
12.           p1 = 1
    
13.        End If
    
14.     ElseIf nb <> 0 And nf <> 0 And na = 0 And nc = 0 Then '仅含b且f
    
15.        If p2 = 0 And Not d.exists(s2) And _
    
16.        Int(ar(i, 1) / 2) <> ar(i, 1) / 2 Then
    
17.           d(s2) = ""
    
18.           p2 = 1
    
19.        End If
    
20.     Else    '其它条件
    
21.        If Int(ar(i, 1) / 2) = ar(i, 1) / 2 And Not d.exists(s2) Then
    
22.          d(s2) = ""
    
23.        End If
    
24.     End If
    
25.   Next
    
26.   [K2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
27. End Sub

复制代码