Search column headers and insert new column if header does not already exist using Excel VBA

Question

I have a spreadsheet that is updated regularly. The user will update two columns on sheet(create) with container type (this is the header name) and the quantity, which will be transferred to sheet(Tracking). I am trying to figure out how to search sheet2(Tracking for existing headers (container types), if found then quantity will be updated within that column for the next available row. If header is not found, therefore a new column is added to the right with that new header name, as well as updating the quantity.

I did find some good example such as the below. However not sure how to apply it. Maybe there could be a way to loop it to search the headers.

Sub TrackR()

Dim cl As Range

    For Each cl In Range("1:1")
        If cl = sheets(“Create”).range(“J11:J36”) Then
           cl.EntireColumn.Insert Shift:=xlToRight
        End If

        cl.Offset(0, 1) = "New Conatainer Name"
    Next cl

Application.ScreenUpdating = False
  Sheets("Tracking").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Date

 'Trailer No.
 Sheets("Create").Range("L8").Copy
 Sheets("Tracking").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

 'total container qty
 Sheets("Create").Range("G43").Copy
 Sheets("Tracking").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

 'Supplier
 Sheets("Create").Range("K4").Copy
 Sheets("Tracking").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

    'quantities
 Sheets("Create").Range("L11").Copy
 Sheets("Tracking").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

 Sheets("Create").Range("L12").Copy
 Sheets("Tracking").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

 Sheets("Create").Range("L13").Copy
 Sheets("Tracking").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

 Sheets("Create").Range("L14").Copy
 Sheets("Tracking").Range("H" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

     Sheets("Create").Range("L15").Copy
 Sheets("Tracking").Range("I" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False

Application.ScreenUpdating = False

End Sub

Answer 1

Not sure, try this ... ~

    Sub TrackB()
Dim wsCreat As Worksheet: Set wsCreat = Sheets("Create")
Dim wsTracking As Worksheet: Set wsTracking = Sheets("Tracking")
Dim cl As Range, lastHCell As Range, header As Range, i As Integer, j As Integer,k as integer, str As Variant
With wsTracking
    Set header = .[a1:xx1]: Set lastHCell = header.End(xlToRight)
    iLstRow = .[a10000].End(xlUp).Offset(1, 0).Row
    'Update default data [A:D]
    .Range("A" & iLstRow) = Date
    For Each str In Array("L8", "C4", "G43")
        .Cells(iLstRow, i + 2) = wsCreat.Range(str): i = i + 1
    Next
        'add Column if not Match
        For Each cl In wsCreat.[B11:B37, E11:E37]
           Dim k: k = Application.Match(cl, header, 0)
           If IsError(k) And cl <> vbNullString Then _
                   lastHCell.Offset(0, 1).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=True: _
                   Set lastHCell = lastHCell.Offset(0, 1): lastHCell.Value2 = cl
        Next cl
        'Update input Data
        i = 5
   Dim arr As Variant:        arr       = Array("B11:B37", "E11:E37")
   Dim arrResult As Variant:  arrResult = Array("C10"    , "F10")
   Dim cell As Range:  k = 0
    For k = 0 To UBound(arr)
        j=1
        For Each cell In wsCreat.Range(arr(k)).Cells
           If cell.Value2 <> vbNullString Then
              .Cells(iLstRow, Application.Match(cell, header, 0)) = wsCreat.Range(arrResult(k)).Offset(j, 0)
           End If
           j = j + 1
        Next cell
    Next
End With
End Sub

Answer 2

Untested but something like this should work:

Sub TrackR()

    Dim wsTrack As Worksheet, wsCreate As Worksheet, cont, qty, h As Range
    Dim c As Range, m, rw As Range, rngHeaders As Range, col As Long

    Set wsCreate = ThisWorkbook.Worksheets("Create")
    Set wsTrack = ThisWorkbook.Worksheets("Track")

    'get the next empty row on the Tracking sheet
    Set rw = wsTrack.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
    'fill in the common cells in the row
    rw.Cells(1).Value = Date
    rw.Cells(2).Value = wsCreate.Range("L8").Value
    rw.Cells(3).Value = wsCreate.Range("K4").Value
    rw.Cells(4).Value = wsCreate.Range("G43").Value

    'now loop over the containers and add each one
    Set rngHeaders = wsTrack.Cells(1, "E").Resize(1, 5000) 'or whatever would cover your data
    For Each c In wsCreate.Range("J11:J36").Cells
        cont = c.Value
        qty = c.Offset(0, 2).Value
        If Len(cont) > 0 And Len(qty) > 0 Then
            m = Application.Match(cont, rngHeaders, 0) 'any existing match ?
            If IsError(m) Then
                'no match - find the first empty cell and add the container
                Set h = rngHeaders.Cells(rngHeaders.Cells.Count).End(xlToLeft).Offset(0, 1)
                h.Value = cont
                col = h.Column 'column number for the added header
            Else
                'matched: get the column number
                col = rngHeaders.Cells(m).Column
            End If
            rw.Cells(col).Value = qty '<< add the quantity
        End If
    Next c

End Sub