エクセル、vba、エクセル-vba、関数、置き換え、別のファイル内のワークシートに基づく最初の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"

辞書ファイルを読み取る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

掃除済み： クリーンhttp://img11.hostingpics.net/pics/221530cleaned.png

PS ：ワークシートのすべてのセルを分析するマクロを知っていますが、列Aを無視するように「簡単に」指示することはできますか？

編集-更新3 ：私のマクロは小さな辞書でうまく動作しますが、マクロが大きくなっても、マクロの実行が停止せず、Ctrl + Alt + SupprでExcelを閉じる必要があります。：xポイントに達したときに停止するように彼女に指示する方法はありますか？

たとえば、 xlByRows 最後の行の後の最初のセルに「END」と書きます。

回答：

回答№1は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:UsersmawDocumentsresourcesDict.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の場合は1

あなたの説明に基づいて、あなたは例えばのようなExcelの数式を使用してこのタスクを完了することができます =IF(ISERROR(SEARCH(B1,C1)),C1,B1) セルD1に入力（サンプルデータに従って「Sony」を返します）：

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

数式を範囲全体に拡張できるため、列Dには「クリーンな」トリミングされたデータが表示されます。また、必要に応じてExcelVBAを介してこの手順を自動化できます。

注意：VBAの反復を含む、投稿された2番目の回答に関連して、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

これが役立つことを願っています。

---