Forum Discussion
Excel VBA to merge cell with different font style
Below is the excel data i have: (Table 1) - each Project has mutiple rows and merged together And i would like to make it like this: (Table 2) - Each project has their own row To u...
Hi @NikeolinoDE, the code you wrote only unmerged the first column of my table.
The code serves as an example, changes or adjustments may be necessary.
I have come all the way to the final stage, but one thing that i am trying to solve now.
I attached my data below too.
When i try to run it line by line, i saw when it runs line 127 copy the date without strikethrough and paste it to the target cell, it removed the strikethrough for the strikethrough date too. but i am not sure why as my code is simply paste the value to the target cell and i expect it should follow the pervious strikethrough thats why my code unstrikethrough the date after pasting it to the target cell. but now it dont work because it DID NOT follow the pervious strikethrough format, it unstrikethrough the pervious date instead...
Before line 127 code: the Apr 18 date should be strikethrough and it is
After line 127 code: the Apr 18 date should be strikethrough and it is NOT
Sub Try1() Dim lastRow As Long, mergedRows As Long Dim i As Long, j As Long, k As Long Sheets("Generated").Select lastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow mergedRows = Range("A" & i).MergeArea.Rows.Count If mergedRows > 1 Then For j = i + 1 To i + mergedRows - 1 Dim L1 As Integer Dim L2 As Integer L1 = Len(Range("H" & i)) L2 = Len(Range("H" & j)) If Range("H" & i).Font.Strikethrough = True Then If InStr(Range("H" & j), "Release") > 0 Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L5 As Integer L5 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L5 - L2 + 1, length:=L2).Font .Strikethrough = False End With ElseIf Range("H" & j).Font.Strikethrough = True Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L3 As Integer L3 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L3 - L2 + 1, length:=L2).Font .Strikethrough = True End With ElseIf Range("H" & j).Font.Strikethrough = False And L2 > 2 Then Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L4 As Integer L4 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L4 - L2 + 1, length:=L2).Font .Strikethrough = False End With ElseIf Range("H" & j).Font.Strikethrough = False And L2 < 2 Then Range("H" & i).Value = Range("H" & i).Value End If ElseIf Range("H" & i).Font.Strikethrough = False Then If InStr(Range("H" & i), "Release") > 0 Then Range("H" & i).Select Range("H" & i).Activate Call Clean_underline If InStr(Range("H" & j), "Release") > 0 Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L8 As Integer L8 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L8 - L2 + 1, length:=L2).Font .Strikethrough = False End With ElseIf Range("H" & j).Font.Strikethrough = True Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L6 As Integer L6 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L6 - L2 + 1, length:=L2).Font .Strikethrough = True End With ElseIf Range("H" & j).Font.Strikethrough = False And L2 > 2 Then Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L7 As Integer L7 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L7 - L2 + 1, length:=L2).Font .Strikethrough = False End With ElseIf Range("H" & j).Font.Strikethrough = False And L2 < 2 Then Range("H" & i).Value = Range("H" & i).Value End If End If Else If InStr(Range("H" & j), "Release") > 0 Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L11 As Integer L11 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L11 - L2 + 1, length:=L2).Font .Strikethrough = False End With ElseIf Range("H" & j).Font.Strikethrough = True Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L9 As Integer L9 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L9 - L2 + 1, length:=L2).Font .Strikethrough = True End With ElseIf Range("H" & j).Font.Strikethrough = False And L2 > 2 Then Range("H" & i).Value = Range("H" & i).Value & Chr(10) & Range("H" & j).Value Dim L10 As Integer L10 = Len(Range("H" & i)) Range("H" & i).Activate With ActiveCell.Characters(Start:=L10 - L2 + 1, length:=L2).Font .Strikethrough = False End With ElseIf Range("H" & j).Font.Strikethrough = False And L2 < 2 Then Range("H" & i).Value = Range("H" & i).Value End If End If Next j Range("A" & i).UnMerge End If Next i Range("A1").Select End Sub Sub Clean_Formats() Dim rng As Range Set rng = Selection rng.Activate With rng.Font .FontStyle = "Regular" .Strikethrough = False .Superscript = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With End Sub Sub Clean_underline() Dim rng As Range Set rng = Selection rng.Activate With rng.Font .Underline = xlUnderlineStyleNone End With End SubSub Try1() Dim lastRow As Long, mergedRows As Long Dim i As Long, j As Long, k As Long Sheets("Generated").Select lastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow mergedRows = Range("A" & i).MergeArea.Rows.Count If mergedRows > 1 Then For j = i + 1 To i + mergedRows - 1 Dim L1 As Integer Dim L2 As Integer L1 = Len(Range("H" & i)) L2 = Len(Range("H" & j)) If Range("H" & i).Font.Strikethrough = True Then If InStr(Range("H" & j), "Release") > 0 Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = True Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = False And L2 > 2 Then ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = False And L2 < 2 Then Range("H" & i).Value = Range("H" & i).Value End If ElseIf Range("H" & i).Font.Strikethrough = False Then If InStr(Range("H" & i), "Release") > 0 Then Range("H" & i).Select Range("H" & i).Activate Call Clean_underline If InStr(Range("H" & j), "Release") > 0 Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = True Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = False And L2 > 2 Then ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = False And L2 < 2 Then Range("H" & i).Value = Range("H" & i).Value End If End If Else If InStr(Range("H" & j), "Release") > 0 Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = True Then Range("H" & j).Select Range("H" & j).Activate Call Clean_Formats ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = False And L2 > 2 Then ' Copy characters and formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Copy ' Paste the copied characters and formatting to the target cell Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ' Clear the clipboard ' Now paste the copied characters without formatting Range("H" & i).Characters(Start:=L1 + 1, Length:=L2).Text = Range("H" & j).Value ElseIf Range("H" & j).Font.Strikethrough = False And L2 < 2 Then Range("H" & i).Value = Range("H" & i).Value End If End If Next j ' Delete the merged rows Rows(i + 1 & ":" & i + mergedRows - 1).Delete End If Next i Range("A1").Select End Sub Sub Clean_Formats() Dim rng As Range Set rng = Selection rng.Activate With rng.Font .FontStyle = "Regular" .Strikethrough = False .Superscript = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With End Sub Sub Clean_underline() Dim rng As Range Set rng = Selection rng.Act rng.Activate With rng.Font .Underline = xlUnderlineStyleNone End With End Sub