Macro to merge cells

Nova1979

Board Regular
Joined
Feb 4, 2020
Messages
101
Office Version
  1. 2010
Platform
  1. Windows
Ladies and gents. I find myself in need of help once again. I am needing to either modify an existing macro to merge cells (much to my disgust) due to layout demands from up higher.
I am currently using a slightly changed version of the following macro (this was the original base)
VBA Code:
Sub transfer_information()
  Dim b As Variant, x As Long, y As Long, lr As Long
  Dim i As Long, j As Long, k As Long, m As Long
 
  With Sheets("INSPECTION")
    lr = .Range("B" & Rows.Count).End(3).Row
    ReDim b(1 To lr, 1 To 8)
    For i = 13 To lr
      If .Range("A" & i).Value = "y" Then
        x = .Range("A" & i).Cells(1).Row
        y = x
        If .Range("A" & i).MergeCells Then y = .Range("A" & i).MergeArea.Rows.Count + x - 1
        If k = j Then k = k + 1
        j = k
        For m = x To y
          If .Range("B" & m).Value <> "" Then b(j, 1) = .Range("B" & m).Value
          b(j, 2) = 0
          If .Range("L" & m).Value <> "" Then b(j, 3) = .Range("L" & m).Value
          If .Range("H" & m).Value <> "" Then b(j, 4) = .Range("H" & m).Value
          If .Range("M" & m).Value <> "" Then b(j, 5) = .Range("M" & m).Value
         
          If .Range("E" & m).Value = "y" Then
            b(k, 6) = .Range("F" & m).Value
            b(k, 7) = .Range("C" & m).Value
            b(k, 8) = .Range("D" & m).Value
            k = k + 1
          End If
         
        Next m
        i = m - 1
      End If
    Next i
  End With
 
  Sheets("REPORT").Rows("2:" & Rows.Count).ClearContents
  Sheets("REPORT").Range("A2").Resize(k, 8).Value = b
End Sub
This produces the following (this is the result of the changes in the above macro)
SerialClassHRSQty Req
1RWELD. Repair bent R/H top rail rack.11504.510741pin2
1RRepair rack holders, replace pins and ropes.127128rope2
168509Screw2
113614Washer2
2FReplace covers0.510861L/S Cover1
210496R/S Cover 1
3FSecure loose1371, 1372 0.5
4RReplace missing rivets, adjust latches, replace box bracket in LHS box.1142,1143, 114741273Washer8
413721 Nut4
4610BOLT4
41852WASHER4
413948WASHER4
5Remove/refit for servicing116361.5
6Replace missing bracket.31557support1
66508Screw6
6104Washer6
7RReplace locking handle bush.1078311073Bush1
75008 rease nipple1
8RReplace 1145611.5122911
810479 Bearing1
9RReplace position. 14591.513391
10XReplace seals.10785, 0802612605Seal1
10XRemove/refit for servicing12446Joiners3
105Seal1
105295Joiner1
1012436Joiners2

I am wanting to either have the above macro modified, OR in independant macro (which may be more realistic) to merge cells to end up with the below result
SerialClassHRSQty Req
1RWELD. Repair bent R/H top rail rack. Repair rack holders, replace pins and ropes.11504.510741pin2
127128rope2
68509Screw2
13614Washer2
2FReplace covers0.510861L/S Cover1
10496R/S Cover 1
3FSecure loose1371, 1372 0.5
4RReplace missing rivets, adjust latches, replace box bracket in LHS box.1142,1143, 114741273Washer8
13721 Nut4
610BOLT4
1852WASHER4
13948WASHER4
5Remove/refit for servicing116361.5
6FReplace missing bracket.31557support1
6508Screw6
104Washer6
7RReplace locking handle bush.1078311073Bush1
508 rease nipple1
8RReplace 1145611.5122911
104729 Bearing1
9RReplace position. 14591.513391
10XReplace seals Remove/refit for servicing10785, 0802612605Seal1
12446Joiners3
5Seal1
5295Joiner1
12436Joiners2

These are only samples. The actual data produced is variable and can range from 100 rows to 800 + rows
I hope I have given enough information.

Can anyone please help

Thanks for all who have taken the time to look
 

Some videos you may like

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.

Watch MrExcel Video

Forum statistics

Threads
1,122,469
Messages
5,596,313
Members
414,052
Latest member
Dual Showman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top