楼主
xmyjk |
Q:在供需表的型号A和供给表的型号B的中进行交叉比较，自动生成供需表。匹配建立连接后列表并标明相似类型。
两列中的单元格字符对比一下，有几种情况：
1.完全相同
2.你中有我
3.我在有你
4.所包含的最长连续英文数字字符相同
5.只对比连续的英文数字字符部分，中文忽略，像空格、- 这样的字符忽略
A:- Option Explicit
- Sub test()
- Dim arr, i&, vr, mhs, j&, brr() As String, x As Long, ar(1 To 2), p, crr(1 To 2)
- Dim d, drr, err
- Set d = CreateObject("scripting.dictionary")
- ar(1) = "需求": ar(2) = "供给"
- For p = 1 To 2
- Sheets(ar(p)).Select
- arr = Range([A2], [a65536].End(3))
- ReDim brr(1 To UBound(arr), 1 To 2) As String
- Set vr = CreateObject("vbscript.regexp")
- With vr
- .Global = True
- .Pattern = "[A-Za-z0-9]+"
- For i = 1 To UBound(arr)
- Set mhs = .Execute(arr(i, 1)): brr(i, 2) = arr(i, 1)
- If mhs.Count >= 2 Then
- x = mhs(0).Length: brr(i, 1) = mhs(0).Value
- For j = 1 To mhs.Count - 1
- If mhs(j).Length > x Then brr(i, 1) = mhs(j).Value
- Next
- Else
- brr(i, 1) = mhs(0).Value
- End If
- Next
- End With
- crr(p) = brr
- Next
- ReDim drr(1 To UBound(crr(1)) * UBound(crr(2)))
- For i = 1 To UBound(crr(1))
- For j = 1 To UBound(crr(2))
- If crr(1)(i, 1) Like "*" & crr(2)(j, 1) & "*" Or crr(2)(j, 1) Like "*" & crr(1)(i, 1) & "*" Then
- d(crr(1)(i, 2) & vbTab & crr(2)(j, 2)) = 0
- End If
- Next
- Next
- ReDim drr(1 To d.Count, 1 To 2)
- err = d.keys
- For i = 0 To d.Count - 1
- drr(i + 1, 1) = Split(err(i), vbTab)(0)
- drr(i + 1, 2) = Split(err(i), vbTab)(1)
- Next
- Sheets("供需表").Select
- Sheets("供需表").UsedRange.Offset(1).Clear
- Sheets("供需表").[A2].Resize(d.Count, 2) = drr
- End Sub
 工作簿22.rar
|
3楼
kwenwu |
1.对比条件只懂编这么两个：(arr(i, 1) Like "*" & brr(j, 1) & "*" Or brr(j, 1) Like "*" & arr(i, 1) & "*") ，不能达到要求；
2.用双数组交叉比较，效率低；
3.多次使用拷贝、插入行、粘贴，这些操作使代码运行很慢。
请哪位老师帮忙改改代码，多谢！- '对比生成供需表
- Sub test()
- On Error Resume Next
-
- Application.ScreenUpdating = False
- Dim arr, brr, i As Long, j As Long, k As Long, l As Long, x As Long
- With Sheets("供给")
- l = .Range("A65536").End(xlUp).Row
- brr = .Range("A1:A" & l)
-
- End With
- With Sheets("供需表")
- k = .Range("A65536").End(xlUp).Row
- arr = .Range("A1:B" & k)
-
- For i = k To 2 Step -1: x = 0
- If arr(i, 2) = "" Then
-
- For j = 2 To l
-
- If (arr(i, 1) Like "*" & brr(j, 1) & "*" Or brr(j, 1) Like "*" & arr(i, 1) & "*") And brr(j, 1) <> "" And arr(i, 1) <> "" Then
-
- .Cells(i, 2).Resize(1, UBound(brr, 2)) = Application.Index(brr, j, 0)
-
- .Cells(i, 1).EntireRow.Copy
-
- .Cells(i, 1).EntireRow.Insert Shift:=xlDown: x = 1
-
- End If
- Next
-
- End If
-
- If x = 1 Then .Cells(i, 1).EntireRow.Delete
-
- Next
-
-
- End With
- Application.ScreenUpdating = True
- End Sub
 工作簿222.zip
|