Macro to Merge 2 Columns with Text Wrap and Text Formatting

[lotus81]

Hello,

I have 2 columns of data.
Column 1 is Song Title. I have this bold and a larger font.
Column 2 is the Artist in italics and a smaller font.

I would like to merge the columns together with a text wrap.
example:
Bad Blood
Taylor Swift

I have been using the Concatenate formula and it works great but it loses the text formatting. So I read up and found that I need a macro. But I don't even know where to start.

Please help.

Thank you in advance.

 

[AnAnalyst]

Ok, here's a little stab at this for you.

Copy the code to a module in your workbook. The code assumes you are working on Sheet1 and that the Title is in column 1 (A), the artist is in column 2 (B), and the concatenation and formatting will go in column 3 (C). It also assumes that the data you want to process starts on row 2.

Sub ConcatAndFormat()
    ' Dimension the variables we will use in the process
    Dim lngRows As Long
    Dim intStartRow As Integer
    Dim intTitleColumn As Integer
    Dim intArtistColumn As Integer
    Dim intTitleAndArtistColumn As Integer
    Dim shtProcessing As Worksheet
    Dim objCell As Object
    Dim intTitleLength As Integer
    Dim intArtistLength As Integer
    Dim rngConcatAndFormat As Range
    ' Specify which sheet is being used
    Set shtProcessing = Sheet1
    ' Which row should the process start with?
    intStartRow = 2
    ' Which column is the song title in?
    intTitleColumn = 1
    ' Which column is the artist name in?
    intArtistColumn = 2
    ' Which column will we perform the join and formatting in?
    intTitleAndArtistColumn = 3
    ' Using the specified sheet ...
    With shtProcessing
        ' Calculate the row we should finish on
        lngRows = .Cells(.Rows.Count, 1).End(xlUp).Row
        ' Specify the range we will be writing to
        Set rngConcatAndFormat = .Cells(intStartRow, intTitleAndArtistColumn).Resize(lngRows - 1, 1)
        ' Iterate through the cells in the range
        For Each objCell In rngConcatAndFormat.Cells
            ' Concatenate the Title with a carriage return and the artist name
            objCell.Value = _
                .Cells(objCell.Row, intTitleColumn).Value & _
                Chr(10) & _
                .Cells(objCell.Row, intArtistColumn).Value
            ' Calculate the length of the title
            intTitleLength = Len(.Cells(objCell.Row, intTitleColumn).Value)
            ' Calculate the length of the artist name
            intArtistLength = Len(.Cells(objCell.Row, intArtistColumn).Value)
            ' Do the formatting ...
            With objCell
                ' ... of the title
                With .Characters(Start:=1, Length:=intTitleLength).Font
                    .Name = "Calibri"
                    .FontStyle = "Bold"
                    .Size = 12
                End With
                ' ... of the artist name
                With .Characters(Start:=intTitleLength + 2, Length:=intArtistLength).Font
                    .Name = "Calibri"
                    .FontStyle = "Italic"
                    .Size = 8
                End With
            End With
        Next objCell
        ' Adjust the column width to fit
        With .Cells(1, intTitleAndArtistColumn)
            .ColumnWidth = 80
            .EntireColumn.AutoFit
        End With
        ' Readjust the row heights
        With rngConcatAndFormat
            .EntireRow.AutoFit
        End With
    End With
    ' Set sheet and range objects to nothing
    Set shtProcessing = Nothing
    Set rngConcatAndFormat = Nothing
End Sub

 

[Jobolobo]

Hey lotus81,

Make sure you have a backup of your work before running this, this will make changes to your sheet and may be hard to reverse. It will however do as you asked. (Bold and text size increased for column A. And Italic and decreased size of text for B.)

[/COLOR]Sub Merge_Bold_Italic()
Dim txtCount1 As Integer
Dim txtCount2 As Integer
Dim txtBld1 As Range
Dim txtNml2 As Range
Dim rMax As Integer


rMax = Sheets("Sheet1").Range("A1").CurrentRegion.Rows.Count


For r = 1 To rMax
    txtCount1 = Sheets("Sheet1").Range("A" & r).Characters.Count
    txtCount2 = Sheets("Sheet1").Range("B" & r).Characters.Count
    
    Set txtBld1 = Sheets("Sheet1").Range("A" & r)
    Set txtNml2 = Sheets("Sheet1").Range("B" & r)
    
    With Sheets("Sheet1").Range("A" & r)
        .Value = txtBld1 & vbLf & txtNml2
        .WrapText = True
        With .Characters(Start:=1, Length:=txtCount1).Font
            .FontStyle = "Bold"
            .Size = 14
        End With
        With .Characters(Start:=txtCount1 + 2, Length:=txtCount2).Font
            .FontStyle = "Italic"
            .Size = 10
        End With
    End With
Next r
Range("B:B").EntireColumn.Delete
End Sub
[COLOR=#574123]

If you have headings you may need to alter the code before running. This works from A1 end of your data.

See how you go

 

[Peter_SSs]

Another option to try. This also has less individual character section processing so should be somewhat faster.
I've assumed data is in columns A:B and starts in row 2, with results to go to column C.

Sub ConcatAndFormat()
  Dim c As Range
  
  Application.ScreenUpdating = False
  With Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
    .WrapText = True
    .EntireColumn.ColumnWidth = 255
    .Value = Evaluate(Replace(Replace("if(len(#),#&char(10)&%,"""")", "#", .Offset(, -2).Address), "%", .Offset(, -1).Address))
    .Font.Italic = True
    .Font.Size = 8
    For Each c In Range(.Address)
      With c.Characters(1, Len(c.Offset(, -2).Value)).Font
        .Size = 12
        .Bold = True
        .Italic = False
      End With
    Next c
    .Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[lotus81]

Thank you everyone! All versions worked great!

 

[Peter_SSs]

Thank you everyone! All versions worked great!

Good news! Thanks for letting us know.