按条件数据提取

yang_159357

如附件，感谢~

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 5).End(xlUp).Row
   
6.     .Range("f3:f" & r).ClearContents
   
7.     arr = .Range("e3:f" & r)
   
8.     For i = 1 To UBound(arr)
   
9.       If Right(arr(i, 1), 1) Like "#" Then
   
10.         arr(i, 2) = arr(i, 1)
    
11.       ElseIf Right(arr(i, 1), 1) = "A" Then
    
12.         arr(i, 2) = arr(i, 1)
    
13.         m = i
    
14.       Else
    
15.         If m = 0 Then
    
16.           arr(i, 2) = arr(i, 1)
    
17.         Else
    
18.           arr(i, 2) = arr(m, 1)
    
19.         End If
    
20.       End If
    
21.     Next
    
22.     .Range("e3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
23.   End With
    
24. End Sub
    

复制代码

chxw68

详见附件。

yang_159357

chxw68 发表于 2019-6-25 15:24

谢谢  老师帮了大忙

yang_159357

chxw68 发表于 2019-6-25 15:25
详见附件。

谢谢  老师帮了大忙

yang_159357

chxw68 发表于 2019-6-25 15:25
详见附件。

老师您好，还得麻烦下，如果像第11行那个没有中间部分相同和结尾为A的数值的话，F列那里直接空白，谢谢

小鹿一样

Sub zimu()
With ThisWorkbook.Sheets(1)
i = 3
For i = 3 To 10
If IsNumeric(Right(.Cells(i, 5), 1)) = True Then
.Cells(i, 6) = .Cells(i, 5)
ElseIf Asc(Right(.Cells(i, 5), 1)) >= 65 And Asc(Right(.Cells(i, 5), 1)) <= 122 Then
.Cells(i, 6) = Left(.Cells(i, 5), Len(.Cells(i, 5)) - 1)
Else
MsgBox ("wrong!")
End If
Next
End With

End Sub

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim reg As New RegExp
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With reg
   
8.     .Global = True
   
9.     .Pattern = "([^\d]+)(\d+)([^\d]*)"
   
10.     Set mh = .Execute(Range("e3"))
    
11.   End With
    
12.    
    
13.   With Worksheets("sheet1")
    
14.     r = .Cells(.Rows.Count, 5).End(xlUp).Row
    
15.     .Range("f3:f" & r).ClearContents
    
16.     arr = .Range("e3:f" & r)
    
17.     For i = 1 To UBound(arr)
    
18.       Set mh = reg.Execute(arr(i, 1))
    
19.       If mh.Count > 0 Then
    
20.         If mh(0).SubMatches(2) = "" Then
    
21.           arr(i, 2) = arr(i, 1)
    
22.         ElseIf mh(0).SubMatches(2) = "A" Then
    
23.           arr(i, 2) = arr(i, 1)
    
24.           d(mh(0).SubMatches(1)) = arr(i, 1) '
    
25.         Else
    
26.           If d.exists(mh(0).SubMatches(1)) Then
    
27.             arr(i, 2) = d(mh(0).SubMatches(1))
    
28.           End If
    
29.         End If
    
30.       End If
    
31.     Next
    
32.     .Range("e3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
33.   End With
    
34. End Sub
    
35. 
    

复制代码

chxw68

详见附件。

yang_159357

chxw68 发表于 2019-6-25 17:13
详见附件。

谢谢