基於另一個文件中的工作表提取第一個Excel文件中的單元格內容

Question

在第一個Excel文件中，列C中的多個單元格包含公司的地址和名稱;我只想保留公司名稱。對於這一點，我有另外一個Excel文件（我稱之爲「詞典」），它具有如下所示的特殊結構：

Column B : Name that I want to keep. 
Column C : Various Patterns of the name, delimited with ";". 
Example : B1 = "Sony", C1="Sony Entertainement;Sony Pictures;Playstation" 

我需要VBA宏讀字典文件，然後爲每個模式（包圍任何東西）用我想要保留的詞替換它。

我的宏看起來像：

Sub MacroClear() 

    <For each line of my dictionnary> 
     arrayC = split(<cell C of my line>, ";") 
     <For i in range arrayC> 
      Cells.Replace What:="*"&Trim(arrayC(i))&"*", Replacement:=Trim(<cell B of my line>), LookAt:= _ 
       xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ 
       ReplaceFormat:=False 
End Sub 

編輯 - 更新：我第一次解釋的捕捉，這將是比較容易理解的結構：

dictionnary http://img11.hostingpics.net/pics/403257dictionnary.png

編輯 - 更新2：我做了一個「非清理」文件的屏幕截圖，然後我想在結尾的結果。

沒有清洗：noclean http://img11.hostingpics.net/pics/418501notcleaned.png

清理：clean http://img11.hostingpics.net/pics/221530cleaned.png

PS：我知道我的宏，因爲它是會分析我的工作表中的所有單元格，是否有可能「輕鬆」地告訴她的不理列A？

編輯 - 更新3：我的宏運行以及小字典，但是當它逐漸變大，我的宏不會停止運行，我必須關閉使用Ctrl + Alt + Suppr脫穎而出。 ：x有沒有辦法讓她在到達某個點時停止？

例如，使用xlByRows並在我的最後一行之後的第一個單元格寫入「END」。

Answer 1

這是你出什麼樣的直譯：

Sub MacroClear() 

Dim wbD As Workbook, _ 
    wbC As Workbook, _ 
    wsD As Worksheet, _ 
    wsC As Worksheet, _ 
    Dic() As String 
'Replace the names in here with yours 
Set wbD = Workbooks("Dictionnary") 
Set wbC = Workbooks("FileToClean") 
Set wsD = wbD.Worksheets("Name1") 
Set wsC = wbC.Worksheets("Name2") 

For i = 1 To wsD.Range("C" & wsD.Rows.Count).End(xlUp).Row 
    Dic = Split(wsD.Cells(i, 3), ";") 
    For k = 1 To wsC.Range("C" & wsC.Rows.Count).End(xlUp).Row 
     Cells.Replace What:=Trim(Dic(i)), _ 
      Replacement:=Trim(wsD.Cells(i, 2)), _ 
      LookAt:=xlPart, _ 
      SearchOrder:=xlByRows, _ 
      MatchCase:=False, _ 
      SearchFormat:=False, _ 
      ReplaceFormat:=False 
    Next k 
Next i 

Set wbD = Nothing 
Set wbC = Nothing 
Set wsD = Nothing 
Set wsC = Nothing 

End Sub 

和更新的版本：

Sub MacroClear() 

Dim wbD As Workbook, _ 
    wbC As Workbook, _ 
    wsD As Worksheet, _ 
    wsC As Worksheet, _ 
    DicC() As Variant, _ 
    Dic() As String, _ 
    ValToReplace As String, _ 
    IsInDic As Boolean, _ 
    rCell As Range 

'Replace the names in here with yours 
Set wbD = Workbooks.Open("D:\Users\maw\Documents\resources\Dict.xlsx", ReadOnly:=True) 
Set wbC = Workbooks("TestVBA") 
Set wsD = wbD.Worksheets("Name1") 
Set wsC = wbC.Worksheets("Name2") 
'Set global dictionnary dimension 
ReDim DicC(1, 0) 

For i = 1 To wsD.Range("C" & wsD.Rows.Count).End(xlUp).Row 
    Dic = Split(wsD.Cells(i, 3), ";") 
    ValToReplace = Trim(wsD.Cells(i, 2)) 
    For k = LBound(Dic) To UBound(Dic) 
     IsInDic = False 
     For l = LBound(DicC, 2) To UBound(DicC, 2) 
      If LCase(DicC(1, l)) <> Trim(LCase(Dic(k))) Then 
       'No match 
      Else 
       'Match 
       IsInDic = True 
       Exit For 
      End If 
     Next l 
     If IsInDic Then 
      'Don't add to DicC 
     Else 
      DicC(0, UBound(DicC, 2)) = Trim(Dic(k)) 
      DicC(1, UBound(DicC, 2)) = ValToReplace 
      ReDim Preserve DicC(UBound(DicC, 1), UBound(DicC, 2) + 1) 
     End If 
    Next k 
Next i 

ReDim Preserve DicC(UBound(DicC, 1), UBound(DicC, 2) - 1) 
wbD.Close 
Erase Dic 


For Each rCell In wsC.Range("C2:C" & wsC.Range("C" & wsC.Rows.Count).End(xlUp).Row).End(xlUp).Row 
    For l = LBound(DicC, 2) To UBound(DicC, 2) 
     If InStr(1, rCell.Value2, DicC(0, l)) <> 0 Then 
      rCell.Value2 = DicC(1, l) 
     Else 
      'Not found 
     End If 
    Next l 
Next rCell 


Erase DicC 
Set wbD = Nothing 
Set wbC = Nothing 
Set wsD = Nothing 
Set wsC = Nothing 

End Sub 

Answer 2

根據您的澄清，您可以使用Excel公式一樣完成這個任務，例如=IF(ISERROR(SEARCH(B1,C1)),C1,B1)單元格D1進入（返回「索尼」按您的樣本數據）：

B   C            D 
Sony  Sony Entertainement;Sony Pictures;Playstation Sony 
Panasonic Panasonic Corporation; Matsushita    Panasonic 
Samsung  Samsung Group;SamsungGalaxy;SamsungApps   Samsung 

可以擴展公式到整個範圍，所以D列將顯示「乾淨」的修剪數據。此外，您可以根據需要通過Excel VBA自動執行此過程。

注：

For i = 1 To wsD.Range("C" & wsD.Rows.Count).End(xlUp).Row 
    For k = 1 To wsC.Range("C" & wsC.Rows.Count).End(xlUp).Row 
     If (InStr(wsC.Cells(k,3).Value, wsD.Cells(i,2).Value)>0 Then 
      'you can assign the value to the Cell in Column C: wsC.Cells(k,3) 
      wsC.Cells(k,4) = wsD.Cells(i,2) 
     End If 
    Next k 
Next i 

希望這可以幫助：有關張貼的第二個答案，其中包括VBA迭代，你可以使用，而不是Split()和Replace() VBA InStr()功能，如使用類似的VBA公式。