[英]Excel VBA - Find cell and add to dynamic array
I have column C with the following structure: 我的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...
I am looking for a macro that finds let's say "Find2"
and then adds all items above "Find2"
(until the first blank cell is reached) to a dynamic VBA array. 我正在寻找一个宏,该宏可以找到
"Find2"
,然后将"Find2"
以上的所有项目(直到到达第一个空白单元格)添加到动态VBA阵列中。 In this example, the array will have item2.1
and item2.2
. 在此示例中,数组将具有
item2.1
和item2.2
。 Any help would be much appreciated. 任何帮助将非常感激。
Something like this should work for you. 这样的事情应该为您工作。 It's a relatively simple task, most of the code here is just error checking.
这是一个相对简单的任务,这里的大多数代码只是错误检查。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.