英文:
Comparing Active Cell Address To Contents of Array
问题
我正在尝试循环遍历给定范围内的值,并将与某些条件匹配的单元格的地址写入数组(为了演示目的,我只是寻找值为"somevalue"的单元格)。然后,我希望再次循环遍历相同的范围,并将活动单元格的地址与写入数组的地址列表进行比较。如果有匹配,则我希望将活动单元格与其下方的两个单元格合并。就是这样。简化的代码如下:
代码运行正常,并将正确的地址记录到数组中。但是在第二个循环的顶部的这一行"If cSched.Address = aBands(x, 1) Then",我遇到以下错误:运行时错误'9':下标超出范围。欢迎提出任何建议!
Sub stackoverflowtest2()
Dim shtSched As Worksheet 'the tab where schedule blocks will be created
Dim rSched As Range 'range of schedule
Dim cSched As Range 'a single cell on Schedule tab
Dim aBands As Variant 'array containing addresses of band locations on schedule
Dim BandCounter As Integer 'counter for number of bands written
Dim x As Integer 'counter
Dim msg As String 'for testing
'Setup
Set shtSched = ActiveWorkbook.ActiveSheet
Set rSched = Range(shtSched.Range("Start"), shtSched.Range("Start").Offset(122, 6))
'Loop 1: work through cells, record address for matches
BandCounter = 1
For Each cSched In rSched
If cSched.Value = "somevalue" Then
ReDim aBands(1 To BandCounter, 1)
aBands(BandCounter, 1) = cSched.Address
msg = msg & aBands(BandCounter, 1) & vbNewLine 'for testing
BandCounter = BandCounter + 1
End If
Next
'Show all matching addresses, for testing
MsgBox msg
'Loop 2: work through cells 2nd time, if address is in array then merge cells
For Each cSched In rSched
For x = 1 To BandCounter
If cSched.Address = aBands(x, 1) Then
MsgBox "We have a match!" 'for testing
Range(cSched, cSched.Offset(2, 0)).MergeCells = True
Exit For
End If
Next x
Next
End Sub
英文:
I am trying to loop through the values in a given range and write to an array the address of any cell that matches some criteria (for demo purposes, I am just looking for cells whose value is "somevalue"). I then want to take a second loop through the same range and compare the address of the active cell to the list of addresses written to the array. If there is a match then I want to merge the active cell with the 2 cells below it. That's it. Simplified code is below.
The code works fine and is recording the correct addresses to the array. But at the top of the second loop at this line "If cSched.Address = aBands(x, 1) Then", I am getting the following error: Run-time error '9': Subscript out of range. All suggestions appreciated!
Sub stackoverflowtest2()
Dim shtSched As Worksheet 'the tab where schedule blocks will be created
Dim rSched As Range 'range of schedule
Dim cSched As Range 'a single cell on Schedule tab
Dim aBands As Variant 'array containing addresses of band locations on schedule
Dim BandCounter As Integer 'counter for number of bands written
Dim x As Integer 'counter
Dim msg As String 'for testing
'Setup
Set shtSched = ActiveWorkbook.ActiveSheet
Set rSched = Range(shtSched.Range("Start"), shtSched.Range("Start").Offset(122, 6))
'Loop 1: work through cells, record address for matches
BandCounter = 1
For Each cSched In rSched
If cSched.Value = "somevalue" Then
ReDim aBands(1 To BandCounter, 1)
aBands(BandCounter, 1) = cSched.Address
msg = msg & aBands(BandCounter, 1) & vbNewLine 'for testing
BandCounter = BandCounter + 1
End If
Next
'Show all matching addresses, for testing
MsgBox msg
'Loop 2: work through cells 2nd time, if address is in array then merge cells
For Each cSched In rSched
For x = 1 To BandCounter
If cSched.Address = aBands(x, 1) Then
MsgBox "We have a match!" 'for testing
Range(cSched, cSched.Offset(2, 0)).MergeCells = True
Exit For
End If
Next x
Next
End Sub
答案1
得分: 1
这可以通过使用嵌套的For循环来实现,以避免重复迭代单元格。
Sub demo()
Dim rCol, i, rSched As Range
Set rSched = Range("B10:H20")
For Each rCol In rSched.Columns
For i = 1 To rCol.Cells.Count
If rCol.Cells(i).Value = "somevalue" Then
rCol.Cells(i).Resize(3, 1).MergeCells = True
i = i + 2
End If
Next
Next
End Sub
英文:
This can be accomplished using nested For loops to avoid iterating cells twice.
Sub demo()
Dim rCol, i, rSched As Range
Set rSched = Range("B10:H20")
For Each rCol In rSched.Columns
For i = 1 To rCol.Cells.Count
If rCol.Cells(i).Value = "somevalue" Then
rCol.Cells(i).Resize(3, 1).MergeCells = True
i = i + 2
End If
Next
Next
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论