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]

Try this with a copy of your workbook.

BTW, I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version.

Sub Shorten()
  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", .Range("B" & .Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(b)
    d(b(i, 1)) = b(i, 2)
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\b(" & Join(Application.Transpose(Application.Index(b, 0, 1)), "|") & ")\b"
  With Sheets("Sheet1")
    a = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(a)
      For Each M In RX.Execute(a(i, 1))
        a(i, 1) = Replace(a(i, 1), M, d(CStr(M)))
      Next M
    Next i
    .Range("B2").Resize(UBound(a)).Value = a
  End With
End Sub

 

[jmacleary]

Hi. this code will do it. It assumes you have your list of Lng/short names in a sheet called 'abbrevs'. Just highlight what you want to abbreviate, and then run this macro.

Option Explicit

Sub Macro1()

    '

    ' assumes you have the range to abbreviate already selected
    Dim KeyVal As Variant
    Dim OneRow As Long
    Dim OneValue As String
    Dim LastRow As Long
    Dim AllRows As New Scripting.Dictionary
    With Sheets("abbrevs")
        LastRow = .Range("A65536").End(xlUp).Row

        For OneRow = 1 To LastRow

            AllRows.Add .Cells(OneRow, 1), .Cells(OneRow, 2)

        Next
    End With
    ' now replace them in the selected range

    For Each KeyVal In AllRows.Keys

        Selection.Replace What:=KeyVal, Replacement:=AllRows(KeyVal).Value, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    
    Next
End Sub

 

[Peter_SSs]

this code will do it.

I'm not so sure. As I understand it the aim is to replace words with their abbreviations. With your code, and the abbreviations of "Company" -> "Co." (which I think the OP might have based on the 2nd row of the first table shown), if a selected cell contained
"See Accompanying Diagram" then the result of your code would be "See AcCo.ing Diagram" which I don't think would be the desired outcome. OP to confirm or contradict of course.

 

[jmacleary]

Peter you are right. I did mean to put an accompanying caution to that effect but forgot (senility setting in). I will wait to see what unknownymous makes of it before doing anything more. Your solution should be good though.

 

[unknownymous]

Try this with a copy of your workbook.

BTW, I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version.

Sub Shorten()
  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", .Range("B" & .Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(b)
    d(b(i, 1)) = b(i, 2)
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\b(" & Join(Application.Transpose(Application.Index(b, 0, 1)), "|") & ")\b"
  With Sheets("Sheet1")
    a = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(a)
      For Each M In RX.Execute(a(i, 1))
        a(i, 1) = Replace(a(i, 1), M, d(CStr(M)))
      Next M
    Next i
    .Range("B2").Resize(UBound(a)).Value = a
  End With
End Sub

= = = =

Hello Peter,

Thanks a lot for this and it really helps. Could you please modify the code as I had to update it? Please..

Also, I noticed like on the abbreviation, when I run the Macro for code ABC Asset Management it became ABC Asset Mgmt. instead of ABC AM. I was thinking its because we a abbrev. for Management which is Mgmt.. Should I sort Sheet 2 in any case so it will pick up what's on top?


Tab 1

Code	Name		Code (After Macro)	Name (After Macro)
001	ABC Management		001	ABC Mgmt.
002	ABC Retirement Company		002	ABC Ret. Co.
003	ABC Corporate System		003	ABC Corp. System
004	ABC Asset Management		004	ABC AM
005	ABC Financial		005	ABC Fin.

Tab 2

Name	Shortcut
Management	Mgmt.
Retirement Company	Ret. Co.
Corporate System	Corp. Sys.
Asset Management	AM
ABC Financial	Fin.

By the way, I am using Microsoft 2016.


Thanks again!

 

[Peter_SSs]

Could you please modify the code as I had to update it?

Do you just mean the change of columns in Sheet1?

Also, I noticed like on the abbreviation, when I run the Macro for code ABC Asset Management it became ABC Asset Mgmt. instead of ABC AM.

That didn't happen for me. Sounds like you may have some non-standard space characters like CHAR(160). Did the Sheet1 names come from the internet?

In any case try this. It doesn't give the same result for the last example but I suspect your last entry for Sheet2 above may be incorrect & it should just be "Financial" not "ABC Financial"?

One further point. My code is case-sensitive so "ABC management" would not become "ABC Mgmt.". If that is a problem for you, post back & I will look at a modification.

Sub Shorten_v2()
  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", .Range("B" & .Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(b)
    d(b(i, 1)) = b(i, 2)
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\b(" & 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) = Replace(a(i, 1), M, d(CStr(M)))
      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

 

[unknownymous]

Do you just mean the change of columns in Sheet1?

That didn't happen for me. Sounds like you may have some non-standard space characters like CHAR(160). Did the Sheet1 names come from the internet?

In any case try this. It doesn't give the same result for the last example but I suspect your last entry for Sheet2 above may be incorrect & it should just be "Financial" not "ABC Financial"?

One further point. My code is case-sensitive so "ABC management" would not become "ABC Mgmt.". If that is a problem for you, post back & I will look at a modification.

Sub Shorten_v2()
  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", .Range("B" & .Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(b)
    d(b(i, 1)) = b(i, 2)
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\b(" & 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) = Replace(a(i, 1), M, d(CStr(M)))
      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

= = =
Thanks a lot Peter and yes, my bad on the Sheet 2 reference which should be "Financial" alone to get "Fin". I just created those names but I think it helps in getting the idea.

The code above is great however, if I have a name like "Florida Retirement Management (FRM)", I get Florida Ret. Mgmt. (FRM). Is there a way I can omit "(FRM)" as it just a duplicate of the abbrev.

Thanks again for any help!

 

[Peter_SSs]

I get Florida Ret. Mgmt. (FRM). Is there a way I can omit "(FRM)" as it just a duplicate of the abbrev.

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

Would any such omissions always be at the end of the text like that one?

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?

 

[unknownymous]

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

Would any such omissions always be at the end of the text like that one?

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?

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.