VBA - Shortcut Name

[unknownymous]

Hi Gurus,

Do you have any VBA codes that I can use to shortcut the name name.

Example:

Tab 1

ABC Management	ABC Mgmt.
ABC Retirement Company	ABC Ret. Co.
ABC Corporate System	ABC Corp. System

In Tab 1, I have the raw name (column 1 above) while in Tab 2 I have list of of name and its shortcuts (see below):

Tab 2:

Management	Mgmt.
Retirement	Ret.
Corporate	Corp.

Basically, if the macro found a string of word in Tab 1 that corresponds in Tab 2, then it will cut the name correspondingly.

I have a long list of words to be added to shortcut the name so any help will be much appreciated.

 

[Peter_SSs]

Thanks Peter for replying back. I thought of putting specific keywords in the Sheet 2 file so other account names will not be affected. Example I added "(FMR)" to sheet 2 which is equal to "" (nothing) thinking the end result would be "Florida Ret. Mgmt." but nothing happened. Once we find the code, I'm all good. Thanks a lot again for looking into this.

I also thought of doing that but my code would need altering. Exactly how I would alter it depends on the answers to my 3 questions but unfortunately you haven't answered any of them yet other than I think your reply indicates that there could be other similar items that need omitting. I would like confirmation either way about that (& if so, a few more examples) as well as responses to the final 2 questions before considering code changes.

 

[unknownymous]

Thanks Peter for replying back. I thought of putting specific keywords in the Sheet 2 file so other account names will not be affected. Example I added "(FMR)" to sheet 2 which is equal to "" (nothing) thinking the end result would be "Florida Ret. Mgmt." but nothing happened. Once we find the code, I'm all good. Thanks a lot again for looking into this.

= = = =

Hi Peter,

See below:

Are there other things like that you would want omitted as well? - None

Would any such omissions always be at the end of the text like that one? - No, as there's a case like ABC Management (US) wherein I won't omit the "(US)" in the name.

If so, could there be other text in parentheses at the end that should not be omitted? That is, could we have a rule that said anything in parentheses at the end should be omitted? - This is in relation to the question above wherein I cited an example. The only way I could think is that for my example - Florida Retirement Management (FRM), I would put "(FRM)" in the tab 2 and will pick-up as blank.

Appreciate your help on this one.

 

[Peter_SSs]

OK, give this a try.
Put the omission in Sheet2 with nothing in column B as we were considering already.

unknownymous 2020-03-03 1.xlsm
	A	B
1	Name	Shortcut
2	Management	Mgmt.
3	Retirement Company	Ret. Co.
4	Corporate System	Corp. Sys.
5	Asset Management	AM
6	Financial	Fin.
7	Retirement	Ret.
8	(FRM)
9
Sheet2

New code:

Sub Shorten_v3()
  Dim RX As Object, M As Object, d As Object
  Dim a As Variant, b As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet2")
    b = .Range("A2:B" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
  End With
  For i = 1 To UBound(b)
    d(LCase(b(i, 1))) = b(i, 2)
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "(\b| )(" & Replace(Replace(Join(Application.Transpose(Application.Index(b, 0, 1)), "|"), "(", "\("), ")", "\)") & ")(\b|$)"
  With Sheets("Sheet1")
    Columns("B").Replace What:=Chr(160), Replacement:=" ", LookAt:=xlPart
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(a)
      For Each M In RX.Execute(a(i, 1))
        a(i, 1) = Trim(Replace(a(i, 1), M, " " & d(LCase(CStr(M.SubMatches(1))))))
      Next M
    Next i
    .Range("A1:B1").Resize(UBound(a) + 1).Copy Destination:=.Range("C1")
    .Range("D2").Resize(UBound(a)).Value = a
  End With
End Sub

My sample data and results:

unknownymous 2020-03-03 1.xlsm
	A	B	C	D
1	Code	Name	Code	Name
2	001	ABC Management	001	ABC Mgmt.
3	002	ABC Retirement Company	002	ABC Ret. Co.
4	003	ABC Corporate System	003	ABC Corp. Sys.
5	004	ABC Asset Management	004	ABC AM
6	005	ABC Financial	005	ABC Fin.
7	006	ABC management	006	ABC Mgmt.
8	007	Florida Retirement Management (FRM)	007	Florida Ret. Mgmt.
Sheet1

 

[unknownymous]

OK, give this a try.
Put the omission in Sheet2 with nothing in column B as we were considering already.

unknownymous 2020-03-03 1.xlsm
	A	B
1	Name	Shortcut
2	Management	Mgmt.
3	Retirement Company	Ret. Co.
4	Corporate System	Corp. Sys.
5	Asset Management	AM
6	Financial	Fin.
7	Retirement	Ret.
8	(FRM)
9
Sheet2

New code:

Sub Shorten_v3()
  Dim RX As Object, M As Object, d As Object
  Dim a As Variant, b As Variant
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet2")
    b = .Range("A2:B" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
  End With
  For i = 1 To UBound(b)
    d(LCase(b(i, 1))) = b(i, 2)
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "(\b| )(" & Replace(Replace(Join(Application.Transpose(Application.Index(b, 0, 1)), "|"), "(", "\("), ")", "\)") & ")(\b|$)"
  With Sheets("Sheet1")
    Columns("B").Replace What:=Chr(160), Replacement:=" ", LookAt:=xlPart
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(a)
      For Each M In RX.Execute(a(i, 1))
        a(i, 1) = Trim(Replace(a(i, 1), M, " " & d(LCase(CStr(M.SubMatches(1))))))
      Next M
    Next i
    .Range("A1:B1").Resize(UBound(a) + 1).Copy Destination:=.Range("C1")
    .Range("D2").Resize(UBound(a)).Value = a
  End With
End Sub

My sample data and results:

unknownymous 2020-03-03 1.xlsm
	A	B	C	D
1	Code	Name	Code	Name
2	001	ABC Management	001	ABC Mgmt.
3	002	ABC Retirement Company	002	ABC Ret. Co.
4	003	ABC Corporate System	003	ABC Corp. Sys.
5	004	ABC Asset Management	004	ABC AM
6	005	ABC Financial	005	ABC Fin.
7	006	ABC management	006	ABC Mgmt.
8	007	Florida Retirement Management (FRM)	007	Florida Ret. Mgmt.
Sheet1

All good here Peter! Thanks a lot for this.

 

[Peter_SSs]

All good here Peter! Thanks a lot for this.

You're welcome. Glad we seem to have got there in the end.
[It was the parentheses that cause some difficulty with this last code adaptation as they are special characters when using Regular Expressions so a bit more 'work' had to be done to accommodate them]