[Request] Need a Macro to acronym my text to 15 Characters

D

desibouy

Board Regular
Joined
Nov 20, 2014
Messages
98
Office Version
  1. 365
Platform
  1. Windows
Hello,

I have a file that I work on a weekly basis to upload item options, and these item options require abbreviations. These are limited to 15 Chars.

So Items options are Alphanumeric, have symbols "/" "-" etc and I've been saving the abbreviations also alphanumeric.

For example, some of my values

[TABLE="width: 500"]
<tbody>[TR]
[TD][TABLE="width: 464"]
<tbody>[TR]
[TD="class: xl65, width: 464"]VALUE[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 133"]
<tbody>[TR]
[TD="class: xl65, width: 133"]ABBREVIATION[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD][TABLE="width: 464"]
<tbody>[TR]
[TD="class: xl65, width: 464"]21 AH[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 133"]
<tbody>[TR]
[TD="class: xl65, width: 133"]21AH[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 500"]
<tbody>[TR]
[TD][TABLE="width: 464"]
<tbody>[TR]
[TD="class: xl65, width: 464"]MDI Spacer For MDI Holding Chamber - Each[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 133"]
<tbody>[TR]
[TD="class: xl65, width: 133"]MS-MHC-EA[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD][TABLE="width: 464"]
<tbody>[TR]
[TD="class: xl65, width: 464"]Spacer Kit, Contains Holding Chamber, Valved Mouthpiece - Each[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 133"]
<tbody>[TR]
[TD="class: xl65, width: 133"]SK-HC-VM-EA[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD][TABLE="width: 464"]
<tbody>[TR]
[TD="class: xl65, width: 464"]Tube 5mm -- Size 60mm L -- 5mm I.D. x 7-2/5mm O.D.[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 133"]
<tbody>[TR]
[TD="class: xl65, width: 133"]T5-S60-5ID-725[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 500"]
<tbody>[TR]
[TD][TABLE="width: 464"]
<tbody>[TR]
[TD="class: xl65, width: 464"]22'' - 1 3/8'' Wide[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 133"]
<tbody>[TR]
[TD="class: xl65, width: 133"]22-13/8-WIDE[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 500"]
<tbody>[TR]
[TD]22'' - 1 3/8'' Wide[/TD]
[TD]22-13/8-WIDE-2[/TD]
[/TR]
</tbody>[/TABLE]


It doesn't matter what the abbreviation is as long as it's under 15. Also, sometimes there will be duplicates like the last one, so this is where I'd add -2, or something else to make it Unique. Yeah, these abbreviation requires being unique.

Can anyone help me, please?

Thanks
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
Your samples don't seem to have a consistent pattern, so I made this since you said that it didn't matter what the abbreviations were. Does this work for you?

Code: 
Private Function Certainchars(r As String) As String
With CreateObject("vbscript.regexp")
    .Pattern = "[^A-Z0-9\\ ]"
    .IgnoreCase = True
    .Global = True
    Certainchars = .Replace(r, "")
End With
End Function

Function MakeAbbreviation(a As Range) As String
Dim t, u As Long, s As String, tmp As String, ct As Long
t = Split(a)
For u = 0 To UBound(t)
    If Val(t(u)) <> 0 Then
        s = s & Val(t(u))
    Else
        s = s & Left(Certainchars(CStr(t(u))), 1)
    End If
Next u
For u = 1 To Len(s) - 3 Step 2
    s = Application.WorksheetFunction.Replace(s, u * 2 + 1, 0, "-")
Next u
MakeAbbreviation = Left(UCase(IIf(Right(s, 1) = "-", Left(s, Len(s) - 1), s)), 15)
ct = Application.WorksheetFunction.CountIf(Range(Cells(2, a.Column), a), a)
If ct > 1 Then MakeAbbreviation = MakeAbbreviation & "-" & ct
End Function


Excel 2010
AB
1VALUEABBREVIATION
221 AH21A
3MDI Spacer For MDI Holding Chamber - EachMS-FMH-CE
4Spacer Kit, Contains Holding Chamber, Valved Mouthpiece - EachSK-CHC-VME
5Tube 5mm -- Size 60mm L -- 5mm I.D. x 7-2/5mm O.D.T5-S60-L5I-X7O
622'' - 1 3/8'' Wide22-13W
722'' - 1 3/8'' Wide22-13W-2
Sheet1
Cell Formulas
RangeFormula
B2=makeabbreviation(A2)
B3=makeabbreviation(A3)
B4=makeabbreviation(A4)
B5=makeabbreviation(A5)
B6=makeabbreviation(A6)
B7=makeabbreviation(A7)
 
Last edited:
Upvote 0
Hi Scott,

Very nice post.

One question, how to include this in personal macro workbook and run on any sheet?

Thanks !!!
 
Last edited:
Upvote 0
Hi arunsjain

Without stepping on the toes of the awesome Scott Huish, place the code in a module in your Personal Workbook, and then call it using the syntax:

Code: 
=PERSONAL.XLSB!makeabbreviation([range])

Cheers

pvr928
 
Upvote 0
Hi Scott,

Thanks. I inserted this into a Module and saved the file as an Excel Macro-enabled file but it's not working.

Nevermind - It's working and I love how it's dealing with duplicates. However, I came across an issue -

I got this option - [TABLE="width: 401"]
<tbody>[TR]
[TD="width: 401"] Tube 4mm -- Size 36mm L -- 4mm I.D. x 6mm O.D[/TD]
[/TR]
</tbody>[/TABLE]

I copied the above 3 times (to check how it dealt with duplicates). by default, your formula is giving me 14 character abbreviation for normal items (Great) however the 3 duplicates is giving me 16 Character abbreviation.

It can't be more than 15 characters, please can you amend this?

Thank you
 
Last edited:
Upvote 0
Try this:

Code: 
Private Function Certainchars(r As String) As String
With CreateObject("vbscript.regexp")
    .Pattern = "[^A-Z0-9\\ ]"
    .IgnoreCase = True
    .Global = True
    Certainchars = .Replace(r, "")
End With
End Function

Function MakeAbbreviation(a As Range) As String
Dim t, u As Long, s As String, tmp As String, ct As Long, totalcount As Long
t = Split(a)
For u = 0 To UBound(t)
    If Val(t(u)) <> 0 Then
        s = s & Val(t(u))
    Else
        s = s & Left(Certainchars(CStr(t(u))), 1)
    End If
Next u
For u = 1 To Len(s) - 3 Step 2
    s = Application.WorksheetFunction.Replace(s, u * 2 + 1, 0, "-")
Next u
MakeAbbreviation = Left(UCase(IIf(Right(s, 1) = "-", Left(s, Len(s) - 1), s)), 15)
ct = Application.WorksheetFunction.CountIf(Range(Cells(2, a.Column), a), a)
totalcount = Application.WorksheetFunction.CountIf(a.EntireColumn, a)
If totalcount > 1 Then MakeAbbreviation = Left(MakeAbbreviation, Len(MakeAbbreviation) - Len(totalcount))
If ct > 1 Then MakeAbbreviation = MakeAbbreviation & "-" & ct
End Function
 
Upvote 0
Hello Scott,



Thanks for this. Sorry been away and only come back yesterday.

It's working but still have issues with some items for example -


[TABLE="width: 575"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Large - Each[/TD]
[TD]LE[/TD]
[/TR]
[TR]
[TD]Leg - Each[/TD]
[TD]LE[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 575"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]5-1/2" x 4" -- Each[/TD]
[TD]5X-4E[/TD]
[/TR]
[TR]
[TD]5 x 4" -- Each[/TD]
[TD]5X-4E[/TD]
[/TR]
[TR]
[TD]4" x 4" - Each[/TD]
[TD]4X-4E[/TD]
[/TR]
[TR]
[TD]3/4" x 3"[/TD]
[TD]3X3[/TD]
[/TR]
[TR]
[TD]3 " x 3"[/TD]
[TD]3X3[/TD]
[/TR]
[TR]
[TD]3 x 3-4/5[/TD]
[TD]3X3[/TD]
[/TR]
[TR]
[TD]Double Deluxe[/TD]
[TD]DD[/TD]
[/TR]
[TR]
[TD]Daisy Dream[/TD]
[TD]DD[/TD]
[/TR]
</tbody>[/TABLE]


So although it's not an exact duplicate the macro is making them. I can't use these. I can manually change these but would be awesome if you could do it, please? Also, would it possible to make them longer? The reason is that some of these duplicates (i.e. 3x3) might already exist in our system so if they were longer (3/4INX3IN) we might not have much. If you can't do it, don't worry I can manually amend those. From my list of 60, I can only see a small amount that might exist.

Thanks

Mayur
 
Upvote 0
Scott, Hi

Found one more error - Notice these two RED options. They're both duplicates however they're very far apart so therefore the formula hasn't detected the duplication and when I tried to upload this file it failed because of the duplicate abbreviation.


[TABLE="width: 394"]
<tbody>[TR]
[TD]Size / Units[/TD]
[TD]2" x 2" - Box of 5[/TD]
[TD]2X-2BO-5[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]4" x 4" - Each[/TD]
[TD]4X-4E[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]4" x 4" - Box of 12[/TD]
[TD]4X-4BO-12[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]4" x 8" - Box of 12[/TD]
[TD]4X-8BO-12[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]4" x 48" Roll - Box of 6 (Roll)[/TD]
[TD]4X-48R-BO6-R[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]4" x 48" Roll - Case of 12 (Roll)[/TD]
[TD]4X-48R-CO1-2R[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]5" x 5" - Each[/TD]
[TD]5X-5E[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]5" x 5" - Box of 5[/TD]
[TD]5X-5BO-5[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]8" x 16" - Box of 6[/TD]
[TD]8X-16B-O6[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]16" x 16" - Box of 6[/TD]
[TD]16-X16-BO6[/TD]
[/TR]
[TR]
[TD]Size / Units[/TD]
[TD]2 x 2 - Box of 5[/TD]
[TD]2X-2BO-5[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,823
Messages
6,181,179
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top