[已解决]怎么实现中文配对?

On_fire · 发表于 2017-11-7 10:54

本帖最后由 On_fire 于 2017-11-7 17:32 编辑

怎么实现中文配对?

1. Data页, 格内数据是中文及英文或字符组合

2. Match页 (代码执行说明), 代码将所有中文字有重复的, 都找出来(当配对上,已经用颜色标注)!

(代码_条件首2个, 3个, 4个,5个或6个中文字, 需求完全配对)

3. ARR页, 模拟结果, 配对后, 排成一行 (注:不用顺序)

数据n多, 请大神, 老师帮帮忙...谢谢!!!

最佳答案

月排行榜 / 总排行榜

grf1973

2017-11-8 09:08

Sub 匹配()
arr = Sheets(1).UsedRange
brr = Sheets(2).UsedRange
Set d = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^\u4e00-\u9fa5]"
For Each x In arr
If Len(x) > 0 Then
y = .Replace(x, "")
d(y) = ""
End If
Next
For Each x In brr
If Len(x) > 0 Then
y = .Replace(x, "")
If d.exists(y) Then d(y) = d(y) & "|" & x
End If
Next
End With
With Sheets(3)
r = 10
.Cells(r, 1).Resize(100, 100).Clear
For Each y In d.keys
If InStr(d(y), "|") Then
yrr = Split(Mid(d(y), 2), "|")
r = r + 1
.Cells(r, 1).Resize(1, UBound(yrr) + 1) = yrr
End If
Next
End With
End Sub

复制代码

跳转到最佳答案楼层

On_fire · 发表于 2017-11-7 12:13

另外, 还有一个情况,

Match页, 如果格内内容, 是完全一样,

ARR页, 模拟结果是两个

比如: 截图中, C4及C8是一样的

ARR页, 模拟结果, 显示两个

On_fire · 发表于 2017-11-7 14:20

On_fire 发表于 2017-11-7 12:13
另外, 还有一个情况, Match页, 如果格内内容, 是完全一样, ARR页, 模拟结果是两个比如: 截图中, C4及C8是 ...

刚发现另一个情况,

Data页可能有其它数据, 除了以中文字符开始的, 其它都不用处理

grf1973 · 发表于 2017-11-8 09:08

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

Sub 匹配()
arr = Sheets(1).UsedRange
brr = Sheets(2).UsedRange
Set d = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^\u4e00-\u9fa5]"
For Each x In arr
If Len(x) > 0 Then
y = .Replace(x, "")
d(y) = ""
End If
Next
For Each x In brr
If Len(x) > 0 Then
y = .Replace(x, "")
If d.exists(y) Then d(y) = d(y) & "|" & x
End If
Next
End With
With Sheets(3)
r = 10
.Cells(r, 1).Resize(100, 100).Clear
For Each y In d.keys
If InStr(d(y), "|") Then
yrr = Split(Mid(d(y), 2), "|")
r = r + 1
.Cells(r, 1).Resize(1, UBound(yrr) + 1) = yrr
End If
Next
End With
End Sub

复制代码

On_fire · 发表于 2017-11-8 10:20

grf1973 发表于 2017-11-8 09:08

谢谢老师帮忙…完美输出结果!

但是, 刚发现如果Match页没有资料, ARR页会变空白?

如果Data页没有数据, 执行代码会报错?

Match页, 本来只是表达执行代码的思路, 不存在的, 请问要怎么完善?

grf1973 · 发表于 2017-11-8 11:03

第3句 brr = Sheets(2).UsedRange 就是针对match页的。
把 Sheets(2).UsedRange 改成相应的比对区域就行。

雄鹰2013 · 发表于 2017-12-1 12:21

Sub 测试() '雄鹰2017.12.1
Dim arr, brr(1 To 1000, 1 To 1), m, crr(1 To 1000, 1 To 100)
Set d = CreateObject("scripting.dictionary")
Set regex = CreateObject("vbscript.regexp")
arr = Sheet1.UsedRange
For i = 1 To UBound(arr)
   For j = 1 To UBound(arr, 2)
      If arr(i, j) <> "" Then
         n = n + 1
         brr(n, 1) = arr(i, j)
      End If
   Next j
Next i
With regex
   .Pattern = "(^[一-隝]+).*"
   .Global = True
   For i = 1 To n
      m = .Execute(brr(i, 1))(0).SubMatches(0)
      d(m) = d(m) & "," & i
   Next i
End With
For Each k In d.keys
   h = h + 1
   ar = Split(d(k), ",")
   For i = 1 To UBound(ar)
      l = l + 1
      crr(h, l) = brr(ar(i), 1)
   Next i
   lm = Application.Max(lm, l)
   l = 0
Next k
Sheet3.[a27].Resize(h, lm) = crr
End Sub

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