Excel VBA – найти ячейку и добавить в динамический массив

У меня есть столбец C со следующей структурой:

[blank cell]
item1.1
item1.2
item1.3
Find1
[blank cell]
item2.1
item2.2
Find2
[blank cell]
item3.1
item3.2
item3.3
Find3
[blank cell]
and so on...

Я ищу макрос, который находит, скажем, "Find2", а затем добавляет все элементы выше "Find2" (пока не будет достигнута первая пустая ячейка) в динамический массив VBA. В этом примере в массиве будут item2.1 и item2.2. Любая помощь приветствуется.

что ты уже испробовал? Если вам нужна подсказка: используйте Find, чтобы найти ожидаемое значение, затем установите диапазон и назначьте его массиву.

Zac 22.05.2019 15:50
3 метода стилизации элементов HTML
3 метода стилизации элементов HTML
Когда дело доходит до применения какого-либо стиля к нашему HTML, существует три подхода: встроенный, внутренний и внешний. Предпочтительным обычно...
Формы c голосовым вводом в React с помощью Speechly
Формы c голосовым вводом в React с помощью Speechly
Пытались ли вы когда-нибудь заполнить веб-форму в области электронной коммерции, которая требует много кликов и выбора? Вас попросят заполнить дату,...
Стилизация и валидация html-формы без использования JavaScript (только HTML/CSS)
Стилизация и валидация html-формы без использования JavaScript (только HTML/CSS)
Будучи разработчиком веб-приложений, легко впасть в заблуждение, считая, что приложение без JavaScript не имеет права на жизнь. Нам становится удобно...
Flatpickr: простой модуль календаря для вашего приложения на React
Flatpickr: простой модуль календаря для вашего приложения на React
Если вы ищете пакет для быстрой интеграции календаря с выбором даты в ваше приложения, то библиотека Flatpickr отлично справится с этой задачей....
В чем разница между Promise и Observable?
В чем разница между Promise и Observable?
Разберитесь в этом вопросе, и вы значительно повысите уровень своей компетенции.
Что такое cURL в PHP? Встроенные функции и пример GET запроса
Что такое cURL в PHP? Встроенные функции и пример GET запроса
Клиент для URL-адресов, cURL, позволяет взаимодействовать с множеством различных серверов по множеству различных протоколов с синтаксисом URL.
0
1
162
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Что-то вроде этого должно сработать для вас. Это относительно простая задача, большая часть кода здесь просто проверяет ошибки.

Sub tgr()

    Dim ws As Worksheet
    Dim rFindText As Range
    Dim rFindBlank As Range
    Dim rData As Range
    Dim aData() As Variant
    Dim sSearchCol As String
    Dim sFind As String
    Dim vData As Variant

    'Adjust these variables to suit your needs
    Set ws = ActiveWorkbook.ActiveSheet
    sSearchCol = "C"
    sFind = "Find4"

    'Find the text you're looking for
    Set rFindText = ws.Columns(sSearchCol).Find(sFind, ws.Cells(ws.Rows.Count, sSearchCol), xlValues, xlWhole, , xlNext)
    If rFindText Is Nothing Then
        'Text not actually found, error out
        MsgBox "No cell found to have [" & sFind & "]", , "Error"
        Exit Sub
    ElseIf rFindText.Row = 1 Then
        'Text found, but it's in row 1 so it can't have any data above it, error out
        MsgBox "[" & sFind & "] found but there is no data for it.", , "Error"
        Exit Sub
    End If

    'Text found and it's not in row 1, now find the first blank cell above the found text
    Set rFindBlank = ws.Range(sSearchCol & 1, rFindText).Find(vbNullString, rFindText, xlValues, xlWhole, , xlPrevious)
    If rFindBlank Is Nothing Then
        'No blank row found above it, assume the data starts at row 1 and set your data range
        Set rData = ws.Range(sSearchCol & 1, rFindText.Offset(-1))
    ElseIf rFindBlank.Row + 1 = rFindText.Row Then
        'Blank cell found, but it's immediately above the found text, so there's no data; error out
        MsgBox "[" & sFind & "] found but there is no data for it.", , "Error"
        Exit Sub
    Else
        'Blank cell found and it's not immediately above the found text, set your data range
        Set rData = ws.Range(rFindBlank.Offset(1), rFindText.Offset(-1))
    End If

    'To avoid an error populating the array, check if the data range is only a single cell
    If rData.Cells.Count = 1 Then
        'Data is a single cell, need to redim and then populate array
        ReDim aData(1 To 1, 1 To 1)
        aData(1, 1) = rData.Value
    Else
        'Data is more than one cell, can populate array directly
        aData = rData.Value
    End If

    'Array now populated with the desired data, do something with it here
    For Each vData In aData
        MsgBox vData
    Next vData

End Sub

Другие вопросы по теме