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

在第一个Excel文件中，C列中的多个单元格包含公司的地址和名称；我只想保留公司名称。为此，我有另一个Excel文件（我称之为“Dictionary”），它具有如下特定结构：

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

Sub宏清除（）
arrayC=拆分（，“；”）
单元格。替换内容：=“*”&Trim（arrayC（i））&“*”，替换：=Trim（），LookAt:=_
xlPart，SearchOrder:=xlByRows，MatchCase:=False，SearchFormat:=False_
ReplaceFormat:=False
端接头

编辑-更新：我捕获了我的第一本词典，这样更容易理解其结构：

编辑-更新2：我制作了一个“未清理”文件的屏幕封盖，然后在最后得到我想要的结果

未清洁：

清洁：

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

编辑-更新3：我的宏在小词典中运行良好，但当它变大时，我的宏不会停止运行，我必须使用Ctrl+Alt+Suppr关闭excel：有没有办法告诉她到达某个点时停止

---

例如，使用

xlByRows

并在最后一行后的第一个单元格中写入“END”。

根据您的说明，您可以使用Excel公式完成此任务，例如

=IF（ISERROR（SEARCH（B1，C1）），C1，B1）

在单元格D1中输入（根据示例数据返回“Sony”）：

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

注意：与发布的第二个答案（包括VBA迭代）相关，您可以使用类似的VBA公式，使用VBA

InStr（）

函数代替

Split（）

和

Replace（）

，如：

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

---

希望这能有所帮助。

这是您所展示内容的直译：

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

Sub宏清除（）
将wbD设置为工作簿_
wbC作为工作簿_
水务署作为工作表_
wsC作为工作表_
DicC（）作为变体_
Dic（）作为字符串_
ValToReplace作为字符串_
IsInDic作为布尔值_
rCell As射程
'将此处的名称替换为您的名称
设置wbD=Workbooks.Open（“D:\Users\maw\Documents\resources\Dict.xlsx”，只读：=True）
设置wbC=工作簿（“TestVBA”）
设置wsD=wbD.工作表（“名称1”）
设置wsC=wbC.工作表（“名称2”）
'设置全局词汇维度
ReDim-DicC（1,0）
对于i=1到wsD.Range（“C”&wsD.Rows.Count）.End（xlUp）.Row
Dic=分割（wsD.单元（i，3），“；”）
ValtoreReplace=修剪（wsD单元（i，2））
k=LBound（Dic）至UBound（Dic）
IsInDic=假
对于l=LBound（DicC，2）到UBound（DicC，2）
如果LCase（DicC（1，l））微调（LCase（Dic（k）），则
“没有对手
其他的
“匹配
IsInDic=真
退出
如果结束
下一个l
如果是印度的话
'不要添加到DicC
其他的
DicC（0，UBound（DicC，2））=微调（Dic（k））
DicC（1，UBound（DicC，2））=ValtoreReplace
重读保存DicC（UBound（DicC，1），UBound（DicC，2）+1）
如果结束
下一个k
接下来我
重读保存DicC（UBound（DicC，1），UBound（DicC，2）-1）
wbD，结束
擦除Dic
对于wsC.Range（“C2:C”和wsC.Range（“C”和wsC.Rows.Count）中的每个rCell。结束（xlUp）。行）。结束（xlUp）。行
对于l=LBound（DicC，2）到UBound（DicC，2）
如果仪表（1，rCell.Value2，DicC（0，l））为0，则
rCell.Value2=DicC（1，l）
其他的
”“没有找到
如果结束
下一个l
下一个rCell
擦除DicC
设置wbD=Nothing
设置wbC=无
设置wsD=无
设置wsC=Nothing
端接头

请澄清您的业务逻辑：您是否希望基于同一工作表中B1中的匹配项（如“Sony Entertainment；Sony Pictures；Playstation”）将B2内容替换为“Sony”？谢谢大家，@AlexBell我犯了一个错误，我写的“B2”实际上是C1^^我要编辑我的帖子来纠正这个错误。是的，我想把“索尼娱乐”、“索尼影业”和“Playstation”（C1）换成“索尼”（B1）。这是你的电话号码。希望对你有帮助！尊敬的，请在宏启动后向我们展示一个预期输出的示例run@Brino我为此编辑了我的问题嗨，谢谢你的回答！但是它不工作，我有一个“错误'9'”。我已经打开了我的文件

TestVBA.xlsm

，它位于

D:\Users\maw\Desktop\excel`中，并保存了您的宏。我的字典在同一个文件夹中，名为

Dict.xlsx

，所以我只是用文件名重命名了这两个“工作簿”，但仍然不起作用。理想情况下，我的字典应该是关闭的，路径应该是：

D:\Users\maw\Documents\resources\Dict.xlsx`。非常感谢。好的，试试更新的版本，（别忘了重命名工作表，因为我不知道它们的名称（这里是

Name1

和

Name2

），它应该会打开你的字典，然后关闭它（所以不要打开它，否则可能会抛出错误）。当我尝试时，我在第9行出现错误：

Set wbC=Workbooks（“TestVBA”）

，因此，我将“TestVBA”替换为“TestVBA.xslm”，现在出现了一个错误9:

如果LCase（DicC（1，l））Trim（LCase（Dic（k）），那么
。我已经做了一个决定，也许会更清楚^^好吧，糟糕的是，我忘了在DicC的L_Ubound中指定哪个维度有2个dim，所以它现在应该可以工作了！：）现在它工作得很好问题是，当匹配时，它不会替换单元格的全部内容，而只替换表达式本身。示例：
新的索尼电影公司电影
现在由<
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