字母加数字，如何匹配数据区间

1506145880

如图，A、B、C、D列为数据，需要匹配出F列的位置

新建 Microsoft Excel 工作表.rar (7.75 KB, 下载次数: 16)

2018-8-31 10:36 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Dim reg As New RegExp
   
5.   With reg
   
6.     .Global = True
   
7.     .Pattern = "^([A-Z]+)(\d+)$"
   
8.   End With
   
9.   With Worksheets("sheet1")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a2:d" & r)
    
12.     xm = ""
    
13.     For i = 1 To UBound(arr)
    
14.       If arr(i, 1) <> xm Then
    
15.         m = m + 1
    
16.         ReDim Preserve zrr(1 To 3, 1 To m)
    
17.         zrr(1, m) = arr(i, 1)
    
18.         zrr(2, m) = i
    
19.         zrr(3, m) = i
    
20.         xm = arr(i, 1)
    
21.       Else
    
22.         zrr(3, m) = i
    
23.       End If
    
24.     Next
    
25.     r = .Cells(.Rows.Count, 6).End(xlUp).Row
    
26.     brr = .Range("f2:g" & r)
    
27.     For i = 1 To UBound(brr)
    
28.       Set mh = reg.Execute(brr(i, 1))
    
29.       If mh.Count > 0 Then
    
30.         lb = mh(0).SubMatches(0)
    
31.         sl = Val(mh(0).SubMatches(1))
    
32.         For k = 1 To UBound(zrr, 2)
    
33.           If zrr(1, k) = lb Then
    
34.             For x = zrr(2, k) To zrr(3, k)
    
35.               If sl > arr(x, 2) And sl <= arr(x, 3) Then
    
36.                 brr(i, 2) = arr(x, 4)
    
37.                 GoTo 100
    
38.               End If
    
39.             Next
    
40.           End If
    
41.         Next
    
42. 100:
    
43.       End If
    
44.     Next
    
45.     .Range("f2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
46.   End With
    
47. End Sub
    

复制代码

chxw68

详见附件。

小花鹿

Sub test()
Dim ar, br, i&, j&, s1, s2
ar = [a1].CurrentRegion
br = [f1].CurrentRegion
For i = 3 To UBound(br)
    For j = 1 To Len(br(i, 1))
        If IsNumeric(Mid(br(i, 1), j, 1)) Then
            Exit For
        End If
    Next j
    s1 = Left(br(i, 1), j - 1)
    s2 = Val(Mid(br(i, 1), j))
    For j = 2 To UBound(ar)
        If ar(j, 1) = s1 And ar(j, 2) <= s2 And ar(j, 3) >= s2 Then
            br(i, 2) = ar(j, 4)
            Exit For
        End If
    Next j
Next i
[f1].Resize(UBound(br), 2) = br
End Sub

astupig

用数组公式也可以：

=LOOKUP(1,0/(($A$2:$A$34=LEFT(F2,LEN(F2)-LEN(MAX(IFERROR(--RIGHT(F2,ROW(INDIRECT("1:" & LEN(F2) & "" ))),0)))))*(MAX(IFERROR(--RIGHT(F2,ROW(INDIRECT("1:" & LEN(F2) & "" ))),0))>=$B$2:$B$34)*(MAX(IFERROR(--RIGHT(F2,ROW(INDIRECT("1:" & LEN(F2) & "" ))),0))<=$C$2:$C$34)),$D$2:$D$34)

weisilisid

路过，留个标记，有时间好好学学

wjcmouse

1. Sub test()
   
2.     Dim str$, str2$, arr, i%, n%, k As Double, brr
   
3. 
   
4.     arr = Worksheets(1).[a1].CurrentRegion
   
5.     brr = Worksheets(1).[f1].CurrentRegion
   
6.    
   
7.     For n = 2 To UBound(brr)
   
8.             str = brr(n, 1)
   
9.             For i = 2 To UBound(arr)
   
10.                 '将货物标号拆分，分开与原始表做对比
    
11.                 k = Val(Right(str, Len(str) - Len(arr(i, 1))))
    
12.                 str2 = Left(str, Len(arr(i, 1)))
    
13.                
    
14.                 If arr(i, 1) = str2 Then
    
15.                    If k >= arr(i, 2) And k <= arr(i, 3) Then
    
16.                       Cells(n, "g").Value = arr(i, 4)

复制代码

Kaohsing

‘js
‘只对本表有效！

1. Sub js_kao()
   
2.     Dim s$, s1
   
3.     Dim ar, br
   
4.     Dim i%, j%, k%
   
5.     Dim y As Object
   
6.     Dim d As Object
   
7.     Dim js As Object
   
8.     Set js = CreateObject("ScriptControl")
   
9.     Set d = CreateObject("Scripting.Dictionary")
   
10.     js.Language = "JScript"
    
11.     ar = [a1].CurrentRegion
    
12.     br = [f1].CurrentRegion
    
13.     '---------------------------------------
    
14.     For i = 2 To UBound(ar)
    
15.         If Not d.exists(ar(i, 1)) Then
    
16.             k = 0
    
17.             d(ar(i, 1)) = ""
    
18.             tt = ar(i, 1)
    
19.             s = "var " & ar(i, 1) & "=[];"
    
20.             js.addcode s
    
21.         End If
    
22.         s = tt & "[" & k & "]=""" & ar(i, 2) & "," & ar(i, 3) & ",'" & ar(i, 4) & "'"";"
    
23.         js.addcode s
    
24.         k = k + 1
    
25.     Next
    
26.      '---------------------------------------
    
27.     For i = 2 To UBound(br)
    
28.         For j = 1 To Len(br(i, 1))
    
29.             If IsNumeric(Mid(br(i, 1), j, 1)) Then Exit For
    
30.         Next j
    
31.         s = Left(br(i, 1), j - 1)
    
32.         s1 = Val(Mid(br(i, 1), j))
    
33.         Set y = js.eval(s)
    
34.         For Each x In y
    
35.             If s1 >= Val(Split(x, ",")(0)) And s1 <= Val(Split(x, ",")(1)) Then
    
36.                 br(i, 2) = Replace(Split(x, ",")(2), "'", "")
    
37.                 Exit For
    
38.             End If
    
39.         Next
    
40.     Next i
    
41.     [f1].CurrentRegion = br
    
42.     MsgBox "job is okey!"
    
43. End Sub
    

复制代码

weisilisid

路过，留个标记，以后好好学习