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关闭excel。：x有没有办法让她在到达某个点时停下来？

例如，在我的最后一行之后的第一个单元格中使用xlByRows并写入“END”。

Answer 1

根据您的说明，您可以使用Excel公式完成此任务，例如在单元格D1中输入=IF(ISERROR(SEARCH(B1,C1)),C1,B1)（根据您的示例数据返回“Sony”）：

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

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

注意：与发布的第二个答案相关，包括VBA迭代，您可以使用类似的VBA公式，使用VBA InStr()函数而不是Split()和{{1} ，像：

Replace()

希望这可能会有所帮助。

Answer 2

这是您所展示内容的字面翻译：

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

根据另一个文件

2 个答案: