How to combine multiple excel cells with formatting - excel

Question

I have 6 cells A1 to F1 (Shown below) in excel
How to concatenate all six cells but my cells with numbers should be subscript. Finally, I should get something like below for each row.
It is a lot of work to do subscript on each and every cell.
Previously I found a VBA code to combine two cells (Concatenation of 2 strings and superscript).

Answer 1

Option Explicit
Sub test()
Call SubscriptIt(Range("A1:H9"))
End Sub
Sub SubscriptIt(rng As Range)
Dim row As Range, cell As Range
Dim col As New Collection, v, ar
Dim i As Integer, s As String
For Each row In rng.Rows
Set col = Nothing
s = ""
' determine position,length of numbers
For Each cell In row.Cells
If IsNumeric(cell) Then
col.Add Len(s) & ":" & Len(cell)
End If
s = s & cell
Next
' output in next column
Set cell = row.Cells(1, rng.Columns.Count + 1)
cell = s
cell.Font.Subscript = False
' apply formatting
For Each v In col
ar = Split(v, ":")
cell.Characters(ar(0) + 1, ar(1)).Font.Subscript = True
Next
Next
MsgBox rng.Rows.Count & " rows updated"
End Sub

Answer 2

Please try this code. It presumes that your 6 cells start in column A and inserts the result in column G.
Sub CombineAndFormat()
' 212
Dim Fun As String ' output string
Dim Arr As Variant ' one row's data
Dim Chars() As Integer ' element length
Dim n As Integer ' character count
Dim i As Long ' loop counter: index
Dim R As Long ' loop counter: rows
Application.ScreenUpdating = False ' speeds up execution
With Worksheets("Sheet1") ' change to suit
' loop through rows 2 to end of column A
For R = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
Arr = .Range(.Cells(R, 1), .Cells(R, 6)).Value
ReDim Chars(1 To UBound(Arr, 2))
Fun = ""
n = 0
For i = 1 To UBound(Arr, 2)
Chars(i) = Len(Arr(1, i))
Fun = Fun & CStr(Arr(1, i))
Next i
With .Cells(R, 7)
.Value = Fun
With .Font ' this is the base font
' .Name = "Calibri" ' specify to suit
' .FontStyle = "Regular"
.Size = 11
.Subscript = False
End With
For i = 1 To 6 Step 2
With .Characters(Start:=n + Chars(i) + 1, Length:=Chars(i + 1)).Font
' this is the subscripted font:-
' .Name = "Calibri" ' specify to suit
' .FontStyle = "Regular"
.Subscript = True
End With
n = n + Chars(i) + Chars(i + 1)
Next i
End With
Next R
End With
Application.ScreenUpdating = True
End Sub

Answer 3

Function Subscript()
'Define Variables
Dim A, B, C, D, E, F As String
Dim l_A, l_B, l_C, l_D, l_E, l_F As Integer
'Read the content of the cells in row 2
A = Worksheets("Sheet14").Cells(2, 1).Value
B = Worksheets("Sheet14").Cells(2, 2).Value
C = Worksheets("Sheet14").Cells(2, 3).Value
D = Worksheets("Sheet14").Cells(2, 4).Value
E = Worksheets("Sheet14").Cells(2, 5).Value
F = Worksheets("Sheet14").Cells(2, 6).Value
'Get the length of each string in the second row
l_A = Len(A)
l_B = Len(B)
l_C = Len(C)
l_D = Len(D)
l_E = Len(E)
l_F = Len(F)
'Write the content of all cells together in the second row in the column G
Worksheets("Sheet14").Cells(2, 7).Value = A & B & C & D & E & F
'Write the content of Cell B as Subscript in Column G
Worksheets("Sheet14").Cells(2, 7).Characters(l_A + 1, l_B).Font.Subscript = True
'Write the content of Cell D as Subscript in Column G
Worksheets("Sheet14").Cells(2, 7).Characters(l_A + l_B + l_C + 1, l_D).Font.Subscript = True
'Write the content of Cell F as Subscript in Column G
Worksheets("Sheet14").Cells(2, 7).Characters(l_A + l_B + l_C + l_D + l_E + 1, l_F).Font.Subscript = True
End Function