[已解决]求助/VB数据提取合并过滤

byeyes · 发表于 2012-8-19 13:14

求助/VB数据提取合并过滤

数据提取.zip (9.08 KB, 下载次数: 30)

happym8888 · 发表于 2012-8-19 13:50

这个网站上还有好多问题没有人回答，其主要原因就是别人看不懂提问者的意图，话只说半句。

byeyes · 发表于 2012-8-19 15:00

happym8888 发表于 2012-8-19 13:50
这个网站上还有好多问题没有人回答，其主要原因就是别人看不懂提问者的意图，话只说半句。

                                       happym8888 你好，麻烦帮解决下

            比如  A1是 ABCDEFG开心       提取/ 乐前面3个数据：开心快
                     A2是快乐happym8888 提取/ 乐后面6个数据： happym 合并成/ 开心快乐happym 过滤/相近的数据

zjdh · 发表于 2012-8-19 15:00

怎么过滤的看不懂！！

byeyes · 发表于 2012-8-19 15:27

zjdh 发表于 2012-8-19 15:00
怎么过滤的看不懂！！

                  喔，zjdh 你好：

               过滤是如果前面已经有       开心快乐happym
                                 后面如果有       S apym 开EXCEL快乐心  ！

                                 假如过滤条件输入是    7          就可以过滤       S apym 开EXCEL快乐心  ！

                                    因为两者有8个相同的字符

周义坤 · 发表于 2012-8-19 16:21

Sub 取值()
Dim arr, i&, j&, k$, arb, arc, l&, m&, n&, ard(1 To 10000, 1 To 1)
arr = Sheet1.Range("A1").CurrentRegion
For i = 1 To UBound(arr, 2)
For j = 1 To UBound(arr)
k = k & arr(j, i)
Next j
Next i
arb = (Len(k) - Len(Replace(k, "201S", ""))) / 4
arc = Split(k, "201S")
l = IIf(UBound(arc) > arb, arb, UBound(arc))
For m = 0 To l
n = n + 1
ard(n, 1) = Right(arc(m), 2)
Next m
With Sheets("提取")
.Range("B5:B10000").ClearContents
.Range("B5").Resize(n) = ard
End With
End Sub

复制代码

数据提取.zip (19.25 KB, 下载次数: 27)

byeyes · 发表于 2012-8-19 16:52

周义坤发表于 2012-8-19 16:21

版主/你好，不知为什么 201S 后面的数据没成功提取到F列

qqyyh · 发表于 2012-8-19 16:53

周义坤 · 发表于 2012-8-19 17:10

再试试：

Sub 取值()
Dim arr, i&, j&, k$, arb, arc, l&, m&, n&, ard(1 To 10000, 1 To 2), are, V&, P&
arr = Sheet1.Range("A1").CurrentRegion
For i = 1 To UBound(arr, 2)
For j = 1 To UBound(arr)
k = k & arr(j, i)
Next j
Next i
arb = (Len(k) - Len(Replace(k, "201S", ""))) / 4
arc = Split(k, "201S")
l = IIf(UBound(arc) > arb, arb, UBound(arc))
For m = 0 To l
n = n + 1
ard(n, 1) = Right(arc(m), 2)
Next m
are = Split(Replace(k, "201S", "201S々"), "201S")
For V = 0 To UBound(are)
If InStr(are(V), "々") Then
P = P + 1
ard(P, 2) = Mid(are(V), 2, 3)
End If
Next V
With Sheets("提取")
.Range("B5:B10000").ClearContents
.Range("B5").Resize(n) = Application.Index(ard, 0, 1)
.Range("f5").Resize(n) = Application.Index(ard, 0, 2)
End With
End Sub

复制代码

周义坤 · 发表于 2012-8-19 17:18

请看附件：

数据提取.zip (19.79 KB, 下载次数: 14)

		自动登录	找回密码
密码			注册

[已解决]求助/VB数据提取合并过滤

评分