如何從字串中比對後抓出需求的資料

lone_tiger0303

如何將L欄位字串與工作表"員工名單"比對，
比對到相同的名字抓到AI欄位
問題如附件

register313

回復 1# lone_tiger0303

資料量大 執行較週

1. Sub zz()
   
2. Application.ScreenUpdating = False
   
3. Dim Rng As Range, Ar
   
4. Set Rng = Sheets("DMS").[L2]
   
5. Range(Rng, [L65536].End(xlUp)).Offset(0, 23) = ""
   
6. Do
   
7.   If InStr(Rng, ",") Then
   
8.      Ar = Split(Rng, ",")
   
9.      For I = 0 To UBound(Ar)
   
10.        Set X = Sheets("員工名單").UsedRange.Find(Ar(I), , xlValues, xlWhole)
    
11.        If Not X Is Nothing Then
    
12.           Rng.Offset(0, 23) = Rng.Offset(0, 23) & X & " "
    
13.        End If
    
14.      Next I
    
15.   Else
    
16.        Set X = Sheets("員工名單").Cells.Find(Rng, , xlValues, xlWhole)
    
17.        If Not X Is Nothing Then
    
18.           Rng.Offset(0, 23) = Rng
    
19.        End If
    
20.   End If
    
21.   Set Rng = Rng.Offset(1)
    
22. Loop Until Rng(1) = ""
    
23. Application.ScreenUpdating = True
    
24. End Sub

複製代碼

2012-01_DMS業代轄區.rar (76.38 KB)

下載次數: 6

2012-2-18 23:51

Hsieh

回復 1# lone_tiger0303

1. Sub nn()
   
2. With Sheets("DMS")
   
3. For Each a In .Range("L2", .[L2].End(xlDown))
   
4. .Cells(a.Row, "AI") = ""
   
5.   ar = Split(a, ",")
   
6.   For Each b In ar
   
7.   Set c = Sheets("員工名單").Cells.Find(b, lookat:=xlWhole)
   
8.      If Not c Is Nothing Then .Cells(a.Row, "AI") = IIf(.Cells(a.Row, "AI") = "", c, .Cells(a.Row, "AI") & "," & c)
   
9.   Next
   
10. Next
    
11. End With
    
12. End Sub

複製代碼

GBKEE

回復 1# lone_tiger0303

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Ar, xA, xF As Range, xS As Integer
   
4.     With Sheets("DMS")
   
5.         Ar = Application.Transpose(.Range("L1", .[L1].End(xlDown)).Value)
   
6.         Ar = Join(Ar, ",")
   
7.         Ar = Split(Ar, ",")
   
8.         With .Range("IR1")
   
9.             .Resize(UBound(Ar)) = Application.Transpose(Ar)
   
10.             .Resize(UBound(Ar)).Offset(, 1) = 1
    
11.             xA = .Resize(UBound(Ar)).Resize(, 2).Address(, , 0)
    
12.             .Offset(, 2).Consolidate xA, xlSum, 0, 1                 '彙算出不重複的名單
    
13.             Erase Ar
    
14.             For Each xA In .Offset(, 2).Resize(Rows.Count, 1).SpecialCells(xlCellTypeConstants)
    
15.                 If xA.Row <> 1 And xA <> "" Then
    
16.                     Set xF = Sheets("員工名單").Cells.Find(xA, lookat:=xlWhole)
    
17.                     If Not xF Is Nothing Then
    
18.                         ReDim Preserve Ar(xS)
    
19.                         Ar(xS) = xA
    
20.                         xS = xS + 1
    
21.                     End If
    
22.                 End If
    
23.             Next
    
24.             .CurrentRegion = ""
    
25.         End With
    
26.         If xS > 0 Then
    
27.             .Range("AI2:AI" & Rows.Count) = ""
    
28.             .Range("AI2").Resize(xS).Value = Application.Transpose(Ar)
    
29.         End If
    
30.    End With
    
31. End Sub

複製代碼

lone_tiger0303

感謝三位老師的指導~~
另外，GBKEE老師~~我要一對一~~重複的名單不用刪除，且不用往上移

GBKEE

回復 5# lone_tiger0303
一對一~~重複的名單不用刪除，且不用往上移
做個範例說明一下

lone_tiger0303

GBKEE老師~~範例如附件

GBKEE

回復 7# lone_tiger0303

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Ar(), xR As String, xF As Range, xS As Integer
   
4.     With Sheets("DMS")
   
5.         Ar = .Range("L2", .[L2].End(xlDown)).Value
   
6.         For xS = 1 To UBound(Ar)
   
7.             xR = Split(Ar(xS, 1), ",")(0)
   
8.             Set xF = Sheets("員工名單").Cells.Find(xR, lookat:=xlWhole)
   
9.             If Not xF Is Nothing Then
   
10.                 Ar(xS, 1) = xF
    
11.             Else
    
12.                 Ar(xS, 1) = ""
    
13.             End If
    
14.         Next
    
15.         .Range("AI2:AI" & Rows.Count) = ""
    
16.         .[AI2].Resize(UBound(Ar)) = Ar
    
17.    End With
    
18. End Sub

複製代碼

lone_tiger0303

測試OK~~感謝您的協助