VBA to add Headers.

[XcelNoobster]

So I have the following report:

I would like to create a VBA macro that when run does the following:
- removes the first 4 rows,
- adds new column "Item Number" and "Description" followed by all headers in row 7(ex. Item Number, Description, Level, Part Type/ Document Type, etc...)
- Adds that sections Item Number and Description to all the entries in that section(for example, Item Number: N711 should be added to the the rows from 8 - 13 THEN Item Number N6501-5 to rows 17-20:

This is what it should look like at the end:

 

[DanteAmor]

Hello @XcelNoobster. Thanks for posting on MrExcel board.


I give you the macro, just support me with 3 data that you must put in the macro.

1) The reference text where the items begin: "Item Number:" In this line:​

sItem = "Item Number:"​

​

2) The name of the sheet where you have the data. In this line:​

With Sheets("Report")​

​

3) And one last piece of information, the output will be in a sheet, so you will have to create a sheet to put the output in and adjust the name on this line:​

With Sheets("Result")​

Try this macro:

Sub AddHeaders()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim f As Range
  Dim sItem As String, iNum As String, iDes As String
  
  sItem = "Item Number:"
  
  With Sheets("Report")
    Set f = .Range("A:A").Find(sItem, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      lr = .Range("A" & Rows.Count).End(3).Row
      lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
      a = .Range("A" & f.Row, .Cells(lr, lc)).Value
    Else
      MsgBox "The text does not exist: " & sItem
      Exit Sub
    End If
  End With
  
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) + 2)
  
  b(1, 1) = "Item Number"
  b(1, 2) = "Description"
  For j = 1 To UBound(a, 2)
    b(1, j + 2) = a(3, j)
  Next
  k = 1
  For i = 1 To UBound(a, 1)
    If a(i, 1) = sItem Then
      iNum = a(i, 2)
      iDes = a(i + 1, 2)
      i = i + 3
    End If
    k = k + 1
    b(k, 1) = iNum
    b(k, 2) = iDes
    For j = 1 To UBound(a, 2)
      b(k, j + 2) = a(i, j)
    Next
  Next
  
  With Sheets("Result")
    .Cells.ClearContents
    .Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------