Поиск заголовков столбцов и вставка нового столбца, если заголовок еще не существует с помощью Excel VBA

Question

У меня есть таблица, которая регулярно обновляется. Пользователь обновит два столбца на листе (создать) с типом контейнера (это название заголовка) и количеством, которое будет перенесено на лист (отслеживание). Я пытаюсь выяснить, как искать лист2 (Отслеживание существующих заголовков (типы контейнеров), если найден, то количество будет обновляться в этом столбце для следующей доступной строки. Если заголовок не найден, следовательно, новый столбец добавляется в прямо с этим новым именем заголовка, а также обновлением количества.

Я нашел хороший пример, такой как приведенный ниже. Однако не уверен, как его применить. Может быть, может быть способ l oop найти его по заголовкам.

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

Не уверен, попробуйте это ... ~

    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

Не проверено, но что-то вроде этого должно работать:

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