One of my friend has created a below coding for me.
Code:
Sub Demo()
Dim i As Long, j As Long, k As Long, t As Single, SngFnt As Single, ArrWdth() As Single
Dim ArrChr As String, StrTmp As String, StrTxt As String, StrFnd As String, StrRep As String
'String Array. As coded, holds character widths for 10pt Arial.
ArrChr = " 2.50 ! 3.35 " & Chr(34) & "4.10 # 5.00 $ 5.00 % 8.25 & 7.75 ' 1.75 ( 3.35 ) 3.35 " & _
"* 5.00 + 5.60 , 2.55 - 3.35 . 2.55 / 2.80 0 5.00 1 5.00 2 5.00 3 5.00 4 5.00 5 5.00 " & _
"6 5.00 7 5.00 8 5.00 9 5.00 : 2.80 ; 2.80 < 5.60 = 5.60 > 5.60 ? 4.45 @ 9.15 A 7.20 " & _
"B 6.65 C 6.65 D 7.20 E 6.10 F 5.55 G 7.20 H 7.20 I 3.35 J 3.90 K 7.20 L 6.10 M 8.85 " & _
"N 7.20 O 7.20 P 5.55 Q 7.20 R 6.65 S 5.55 T 6.10 U 7.20 V 7.20 W 9.45 X 7.20 Y 7.20 " & _
"Z 6.10 [ 3.35 \ 2.75 ] 3.35 ^ 4.70 _ 5.00 ` 3.35 a 4.45 b 5.00 c 4.45 d 5.00 e 4.45 " & _
"f 3.35 g 5.00 h 5.00 i 2.80 j 2.80 k 5.00 l 2.80 m 7.75 n 5.00 o 5.00 p 5.00 q 5.00 " & _
"r 3.35 s 3.90 t 2.80 u 5.00 v 5.00 w 7.20 x 5.00 y 5.00 z 4.45 { 4.80 | 1.95 } 4.80 ~ 5.45 "
'Input the font size & divide by 10 for scaling the output
SngFnt = 12 / 10
'Initialize the output String-width array
ReDim Preserve ArrWdth(1)
'Initialize the Find String
StrFnd = "(^13*)"
With ActiveDocument.Range
' Loop through all paragraphs
For i = 1 To .Paragraphs.Count
'Get the paragraph text, minus the paragraph marker
StrTmp = .Paragraphs(i).Range.Text
StrTmp = Left(StrTmp, Len(StrTmp) - 1)
'Redim the output String-width array, as necessary
If UBound(Split(StrTmp, vbTab)) > UBound(ArrWdth) Then
ReDim Preserve ArrWdth(UBound(Split(StrTmp, vbTab)))
End If
'Process each tab-separated block, ignoring the first one
For j = 1 To UBound(Split(StrTmp, vbTab))
StrTxt = Split(StrTmp, vbTab)(j)
'If there's a decimal number, trim to the last digit
'If InStr(StrTxt, ".") > 0 Then
If StrTxt Like "*.[0-9]*" Then
While Not IsNumeric(Right(StrTxt, 1))
StrTxt = Left(StrTxt, Len(StrTxt) - 1)
Wend
End If
'Calculate the string width, based on a 10pt font
t = 0
For k = 1 To Len(StrTxt)
t = t + Split(Split(ArrChr, " " & Mid(StrTxt, k, 1) & " ")(1), " ")(0)
Next
'Re-scale the calculation for the required point size
t = t * SngFnt
'Update the output String-width array
If t > ArrWdth(j) Then ArrWdth(j) = t
Next
Next
'Parse the string to be updated
'StrTmp = Split(.Paragraphs.First.Range.Text, vbTab)(0)
For i = 1 To .Paragraphs.Count
If UBound(Split(.Paragraphs(i).Range.Text, vbTab)) = UBound(ArrWdth) Then
'Parse the string to be updated
StrTmp = Split(.Paragraphs(i).Range.Text, vbTab)(0)
Exit For
End If
Next
'Split at ',")'
j = UBound(Split(StrTmp, Chr(44) & Chr(148) & ")")) - 1
For i = 0 To j
StrTxt = Split(StrTmp, Chr(44) & Chr(148) & ")")(i)
If i = 0 Then
'For the first item, re-split at '('
StrTxt = Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, "("))
Else
'For the remaining items, re-split at '"'
StrTxt = Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, Chr(147)))
End If
'Update the Find expression
StrFnd = StrFnd & StrTxt & "(*)"
Next
'Finalize the Find string
StrFnd = Left(StrFnd, Len(StrFnd) - 3) & "([!^13]{1,})"
'Add the 'master' width to the output String-width array
ReDim Preserve ArrWdth(j + 2)
ArrWdth(j + 2) = StrTxt
'Re-calculate the output String-width array elements
For i = UBound(ArrWdth) - 1 To 0 Step -1
ArrWdth(i) = ArrWdth(i + 1) - ArrWdth(i) - 10
Next
'Generate the Replace string
For i = 1 To UBound(ArrWdth) - 1
StrRep = StrRep & "\" & i & Round(ArrWdth(i + 1), 0)
Next
'Finalize the Replace string
StrRep = StrRep & "\" & i
'Add a temporary paragraph at the start of the document
.InsertBefore vbCr
'Update the document
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Text = StrFnd
.Replacement.Text = StrRep
.execute replace:=wdReplaceAll
End With
'Delete the temporary paragraph at the start of the document
.Characters.First = vbNullString
End With
End Sub
The macro do the following.
1. Find out each and every character width from the Tab Delimited Text from the given Array. Character width is calculated (From Tab upto the numeric value except the hanging characters i.e., “)”, “*”, “%” etc.,)
2. Find out the maximum width of the each column.
3. Minus it with the values which is available on the Starting of the Paragraph and
4. Replace the Value
Coding Runs from the last column to the first column.
But the macro throws “Type mismatch” error (Highlighted in the Coding). At present I am unable to contact my friend.
I doesn’t know Visual Basic.
So if any one fix this Error. It will be greatly appreciated.
* The Best Reasons to Target Windows 8
Learn some of the best reasons why you should seriously consider bringing your Android mobile development expertise to bear on the Windows 8 platform.