Sub Strformats(ByVal shName As String)
Dim Rng As Range, tStr As String
Dim i As Long, j As Long, sCol As Long, nlen As Long
With Sheets(shName)
sCol = .Range("A1").End(xlToRight).Column
Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
For i = 1 To Rng.Rows.Count
tStr = Rng(i, 1).Value
For j = 2 To sCol - 1
Select Case shName
Case "Sheet1"
tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
Case "Sheet2"
tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
Case "Sheet3"
tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
End Select
Next j
With Rng(i, sCol)
.Value = tStr
nlen = 0
For j = 1 To sCol - 1
nlen = nlen + Len(Rng(i, j)) + IIf(shName = "Sheet2" And j = 2, 0, 1)
.Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
.Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
.Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
.Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
.Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
Next j
End With
Next i
End With
End Sub
Sub Button2_Click()
Dim i As Long, shArr()
shArr = Array("Sheet1", "Sheet2", "Sheet3")
Application.ScreenUpdating = False
For i = 0 To UBound(shArr)
Call Strformats(shArr(i))
Next
Application.ScreenUpdating = True
End Sub