Board logo

標題: 如何從字串中比對後抓出需求的資料 [打印本頁]
作者: lone_tiger0303    時間: 2012-2-18 22:22     標題: 如何從字串中比對後抓出需求的資料

如何將L欄位字串與工作表"員工名單"比對，
比對到相同的名字抓到AI欄位
問題如附件
作者: register313    時間: 2012-2-18 23:51

回復 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
複製代碼
[attach]9644[/attach]
作者: Hsieh    時間: 2012-2-19 00:14

回復 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    時間: 2012-2-19 11:13

回復 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    時間: 2012-2-19 12:21

感謝三位老師的指導~~
另外，GBKEE老師~~我要一對一~~重複的名單不用刪除，且不用往上移
作者: GBKEE    時間: 2012-2-19 15:44

回復 5# lone_tiger0303
一對一~~重複的名單不用刪除，且不用往上移
做個範例說明一下
作者: lone_tiger0303    時間: 2012-2-22 12:27

GBKEE老師~~範例如附件
作者: GBKEE    時間: 2012-2-22 13:23

回復 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    時間: 2012-2-23 12:26

測試OK~~感謝您的協助



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)