[已解决]求助通过字段过滤筛选生成新的航班号(用宏实现)

335805371

D列是想要生成的，根据A列前三个字母，与B列匹配，如果匹配到了取对应C列加A列截取掉前三个字母后的值，匹配不到取A列原值。
注：A列有几万行数据,B列有二百多行数据,C列与B列相对应，C列单元值可能为空

A                                  B              C                     D
需要过滤的航班号       三字码        二子码           新生成的航班号
AAR201                      DKH            RK                AR201
ABW139                     CAL             KJ                RA139
BAW3304                   ABW            RA               BAW3304
CAL063                      NEG                                KJ063
THY342                      AAR            AR                THY342
HRY3324                    CAL             EU                HRY3324
DKH879                                                            RK879
CAL234                                                             KJ234
AAR0987                                                           AR0987
EYT209                                                             EYT209

最佳答案

月排行榜 / 总排行榜

windimi007

2014-6-13 10:02

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim ar
   
4.     Dim i As Long
   
5.     Dim sr As String
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Cells(2, 4).Resize(Rows.Count - 1).ClearContents
   
8.     ar = Cells(1, 1).CurrentRegion
   
9.     For i = 2 To UBound(ar)
   
10.         If Not IsEmpty(ar(i, 2)) Then
    
11.             If Not d.exists(ar(i, 2)) Then d.Add ar(i, 2), ar(i, 3)
    
12.         End If
    
13.     Next i
    
14.     For i = 2 To UBound(ar)
    
15.         sr = Left(ar(i, 1), 3)
    
16.         If d.exists(sr) Then
    
17.             ar(i, 4) = Replace(ar(i, 1), sr, d(sr))
    
18.         Else
    
19.             ar(i, 4) = ar(i, 1)
    
20.         End If
    
21.     Next i
    
22.     Cells(1, 1).Resize(UBound(ar), 4) = ar
    
23. End Sub
    

复制代码

跳转到最佳答案楼层

windimi007

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim ar
   
4.     Dim i As Long
   
5.     Dim sr As String
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Cells(2, 4).Resize(Rows.Count - 1).ClearContents
   
8.     ar = Cells(1, 1).CurrentRegion
   
9.     For i = 2 To UBound(ar)
   
10.         If Not IsEmpty(ar(i, 2)) Then
    
11.             If Not d.exists(ar(i, 2)) Then d.Add ar(i, 2), ar(i, 3)
    
12.         End If
    
13.     Next i
    
14.     For i = 2 To UBound(ar)
    
15.         sr = Left(ar(i, 1), 3)
    
16.         If d.exists(sr) Then
    
17.             ar(i, 4) = Replace(ar(i, 1), sr, d(sr))
    
18.         Else
    
19.             ar(i, 4) = ar(i, 1)
    
20.         End If
    
21.     Next i
    
22.     Cells(1, 1).Resize(UBound(ar), 4) = ar
    
23. End Sub
    

复制代码

335805371

windimi007 发表于 2014-6-13 10:02

执行了，很正确，非常感谢！