返回列表 上一主題 發帖

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

lone_tiger0303

帖子
76 
主題
19 
精華
0 
積分
145 
點名
0  
作業系統
win xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2010-5-24 
最後登錄
2014-6-24 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-2-18 22:22 | 只看該作者

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

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

2012-01_DMS業代轄區.zip (322.66 KB)

收藏 分享

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
2#
發表於 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
複製代碼
2012-01_DMS業代轄區.rar (76.38 KB)

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
277  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-12-23 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 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
複製代碼

TOP

lone_tiger0303

帖子
76 
主題
19 
精華
0 
積分
145 
點名
0  
作業系統
win xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2010-5-24 
最後登錄
2014-6-24 
5#
發表於 2012-2-19 12:21 | 只看該作者
感謝三位老師的指導~~
另外，GBKEE老師~~我要一對一~~重複的名單不用刪除，且不用往上移

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2012-2-19 15:44 | 只看該作者
回復 5# lone_tiger0303
一對一~~重複的名單不用刪除，且不用往上移
做個範例說明一下

TOP

lone_tiger0303

帖子
76 
主題
19 
精華
0 
積分
145 
點名
0  
作業系統
win xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2010-5-24 
最後登錄
2014-6-24 
7#
發表於 2012-2-22 12:27 | 只看該作者
GBKEE老師~~範例如附件

2012-01_DMS業代轄區.zip (286.5 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 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
複製代碼

TOP

lone_tiger0303

帖子
76 
主題
19 
精華
0 
積分
145 
點名
0  
作業系統
win xp 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2010-5-24 
最後登錄
2014-6-24 
9#
發表於 2012-2-23 12:26 | 只看該作者
測試OK~~感謝您的協助

TOP

        靜思自在 : 欣賞別人就是莊嚴自己。
返回列表 上一主題