CODEWITHSUNDEEP
vbaexcelfunctionreplace
Malik
Malik

Reputation: 207

Extract Cells content in the first Excel File based on Worksheet in another File

In a first Excel File multiple Cells in Column C contains the address and the name of a company; I want to keep only the company name. For that, I have another Excel file (I'll call it "Dictionary"), which has a particular structure like the following:

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"

I need VBA macro reading Dictionary File, then for each pattern (surrounded with anything) replace it with the word I want to keep.

My macro would look like :

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

EDIT - UPDATE : I made a capture of my first Dictionary, it'll be easier to understand the structure :

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

EDIT - UPDATE 2 : I made a screen cap of a "non-cleaned" file, then the result I want at the end.

Not cleaned : noclean http://img11.hostingpics.net/pics/418501notcleaned.png

Cleaned :     clean http://img11.hostingpics.net/pics/221530cleaned.png

PS : I know my macro as it is would analyze all the cells of my worksheet, is it possible "easily" to tell her to ignore column A ?

EDIT - UPDATE 3 : My macro runs well with small dictionaries, but when it grows bigger, my macro doesn't stop running and I have to close excel with Ctrl + Alt + Suppr. :x Is there a way to tell her to stop when reaching a point ?

For example, using xlByRows and writing "END" at the first cell after my last row.

Upvotes: 0

Views: 138

Answers (2)

R3uK
R3uK

Reputation: 14537

This is the literal translation of what you shown :

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

And the updated version :

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

Upvotes: 1

Alexander Bell
Alexander Bell

Reputation: 7918

Based on your clarification, you can complete this task using Excel Formula like, for example =IF(ISERROR(SEARCH(B1,C1)),C1,B1) entered in cell D1 (returns "Sony" as per your sample data):

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

You can extend the Formula to entire Range, so column D will display the "clean" trimmed data. Also, you can automate this procedure via Excel VBA upon necessity.

NOTE: Pertinent to the 2nd answer posted, which include VBA iteration, you can use similar VBA formula using VBA InStr() function instead of Split() and Replace(), like:

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

Hope this may help.

Upvotes: 1

Related Questions