Использование vba для поиска заголовков столбцов и добавление новой записи под этим заголовком

Question

Я пытаюсь создать что-то, способное взять значение из одного текстового поля, найти группу заголовков столбцов, чтобы найти правильный, и затем поместить новое значение из второго текстового поля в последнюю строку под этим колонка. Я адаптировал этот код, который нашел здесь, { ссылка }, но мне нужна помощь. Этот код публикует значение из второго текстового поля под каждым заголовком, и я хотел бы, чтобы он публиковал его только под заголовком, который находится в текстовом поле 1. Кто-нибудь может мне помочь и объяснить, как я могу сделать эту работу? Я новичок в VBA, поэтому любые объяснения будут с благодарностью.

Public Sub FindAndConvert()
Dim i           As Integer
Dim lastRow     As Long
Dim myRng       As Range
Dim mycell      As Range
Dim MyColl      As Collection
Dim myIterator  As Variant

Set MyColl = New Collection

MyColl.Add "Craig"
MyColl.Add "Ed"

lastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = 1 To 25
    For Each myIterator In MyColl
        If Cells(1, i) = myIterator Then
            Set myRng = Range(Cells(2, i), Cells(lastRow, i))
            For Each mycell In myRng
                mycell.Value = Val(mycell.Value)
            Next
        End If
    Next
Next
End Sub  

Answer 1

Basi c пример:

Sub tester()

    AddUnderHeader txtHeader.Text, txtContent.Text

End Sub

'Find header 'theHeader' in row1 and add value 'theValue' below it,
'  in the first empty cell 
Sub AddUnderHeader(theHeader, theValue)
    Dim m
    With ThisWorkbook.Sheets("Data")
        m = Application.Match(theHeader, .Rows(1), 0)
        If Not IsError(m) Then
            'got a match: m = column number
            .Cells(.Rows.Count, m).End(xlUp).Offset(1, 0).Value = theValue
        Else
            'no match - warn user
            MsgBox "Header '" & theHeader & "' not found!", vbExclamation
        End If
    End With
End Sub

Answer 2

Я прокомментировал ваш код для вашего лучшего понимания. Вот оно.

Public Sub FindAndConvert()

    Dim i           As Integer
    Dim lastRow     As Long
    Dim myRng       As Range
    Dim myCell      As Range
    Dim MyColl      As Collection
    Dim myIterator  As Variant

    Set MyColl = New Collection

    MyColl.Add "Craig"
    MyColl.Add "Ed"
    Debug.Print MyColl(1), MyColl(2)        ' see output in the Immediate Window

    ' your code starts in the top left corner of the sheet,
    ' moves backward (xlPrevious) from there by rows (xlByRows) until
    ' it finds the first non-empty cell and returns its row number.
    ' This cell is likely to be in column A.
    lastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    For i = 1 To 25                         ' do the following 25 times
        ' in Cells(1, i), i represents a column number.
        ' 1 is the row. It never changes.
        ' Therefore the code will look at A1, B1, C1 .. until Y1 = cells(1, 25)
        For Each myIterator In MyColl       ' take each item in MyColl in turn
            If Cells(1, i) = myIterator Then
                ' set a range in the column defined by the current value of i
                ' extend it from row 2 to the lastRow
                Set myRng = Range(Cells(2, i), Cells(lastRow, i))
                ' loop through all the cells in myRng
                For Each myCell In myRng
                    ' convert the value found in each cell to a number.
                    ' in this process any non-numeric cells would become zero.
                    myCell.Value = Val(myCell.Value)
                Next myCell
            End If
        Next myIterator
    Next i
End Sub

Как видите, TextBox нигде не задействован. Поэтому ваш вопрос не может быть легко понят. Тем не менее, мои объяснения могут позволить вам изменить его. Все дело в идентификации ячеек на листе по их координатам и присвоении им правильного значения.

Answer 3

Изменить / Преамбула

Извините , не прочитал, что вы хотите использовать Текстовые поля и собирать данные один за другим вместо применения процедуры ко всему диапазону данных.

Тем не менее я не удаляю следующий код, так как некоторые читатели могут счесть мой подход полезным или хотят изучить довольно неизвестное использование функции Application.Match() :)

Найти все столбцы заголовка с помощью одного Match()

Этот (поздний) подход предполагает использование данных из двух столбцов диапазон (идентификатор заголовка и подключенное значение).

Демонстрируется способ поиска всех существующих столбцов заголовка путем выполнения single Application.Match() в ►one вкладке ~> см. Шаг [3].

Дополнительная функция: Если в существующих заголовках не найдены идентификаторы, массив ItemCols получает элементы Error; шаг [4] проверяет возможные элементы ошибок, добавляя эти значения в последний столбец.

В других шагах используются справочные функции , как указано ниже.

• [1] getDataRange() получает данные диапазона, назначая их массиву вариантных данных
• [2] HeaderSheet() получает заголовки как "плоский" массив на основе 1 и устанавливает целевой лист
• [3] см. объяснение выше
• [4] nxtRow() получает следующую свободную строку в целевом листе перед записью в найденный столбец

Пример вызова

Sub AddDataToHeaderColumn()
    '[1] get range data assigning them to variant data array
    Dim rng As Range, data
    Set rng = getDataRange(Sheet1, data)       ' << change to data sheet's Code(Name)

    '[2] get headers as 1-based "flat" array
     Dim targetSheet As Worksheet, headers
     Set targetSheet = HeaderSheet(Sheet2, headers)

    '[3] match header column numbers (writing results to array ItemCols as one liner)
    Dim ids:      ids = Application.Transpose(Application.Index(data, 0, 1))
    Dim ItemCols: ItemCols = Application.Match(ids, Array(headers), 0)

    '[4] write data to found column number col
    Dim i As Long, col As Long
    For i = 1 To UBound(ItemCols)
        'a) get column number (or get last header column if not found)
         col = IIf(IsError(ItemCols(i)), UBound(headers), ItemCols(i))
        'b) write to target cells in found columns
        targetSheet.Cells(nxtRow(targetSheet, col), col) = data(i, 2)
    Next i
End Sub

Функции справки

Я перевел части основной процедуры в некоторые вызовы функций для лучшей читабельности и, по возможности, помощи пользователям, продемонстрировав некоторые неявные ByRef аргументы, такие как [ByRef] mySheet или передавая пустой массив, такой как data или headers.

'[1]
Function getDataRange(mySheet As Worksheet, data) As Range
'Purpose: assign current column A:B values to referenced data array
'Note:    edit/corrected assumed data range in columns A:B
With mySheet
    Set getDataRange = .Range("A2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    data = getDataRange          ' assign range data to referenced data array
End With
End Function

'[2]
Function HeaderSheet(mySheet As Worksheet, headers) As Worksheet
'Purpose: assign titles to referenced headers array and return worksheet reference
'Note:    assumes titles in row 1
With mySheet
    Dim lastCol As Long: lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    headers = Application.Transpose(Application.Transpose(.Range("A1").Resize(1, lastCol)))
End With
Set HeaderSheet = mySheet
End Function

'[4]
Function nxtRow(mySheet As Worksheet, ByVal currCol As Long) As Long
'Purpose: get next empty row in currently found header column
With mySheet
     nxtRow = .Cells(.Rows.Count, currCol).End(xlUp).Row + 1
End With
End Function