Excel VBA - 查找彩色行的开头和结尾 [英] Excel VBA - Finding the beginning and end of coloured rows
问题描述
我试图在Excel VBA中创建一个代码,以找到表中的彩色行的开始(单元格地址)和结束(单元格地址)。表格是时间轴(水平轴 - 日期,垂直轴 - 常规文本)。彩色行都不会在第一列中开始,而是从不同的列开始。
任何帮助?
I am trying to create a code in Excel VBA, to locate the beginning (Cell Address) and the end (Cell Address) of coloured rows in a table. The table is a timeline(Horizontal axis- Dates, Vertical axis - General Text). The coloured rows all do not start in the first column, but start in different columns. Any help?
推荐答案
这是什么?
Sub findColoredRows()
Dim startCol As Integer, endCol As Integer, o As Integer
Dim ws As Worksheet
Dim i As Integer, k As Integer
Dim startRow As Long, endRow As Long
Dim cellColor As String, noColor As String
Dim cel As Range
noColor = -4142 ' this is the color index of NO coloring
k = 3
Set ws = ActiveSheet
With ws
startRow = .Cells(1, 3).End(xlDown).Row
startCol = .Cells(1, 3).Column
Do While startRow > 100 ' I assume your table starts before row 100. So, if there's no data before row 100, check next column
k = k + 1
startRow = .Cells(1, k).End(xlDown).Row
startCol = k
Loop
'Now, we have our starting row - get end row.
endRow = .Cells(startRow, k).End(xlDown).Row
endCol = .Cells(startRow, startCol).End(xlToRight).Column
Debug.Print "Start row: " & startRow & ", start column: " & startCol
' How many non colored cells is there in our range?
Dim noColorCells As Integer
For Each cel In .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
If cel.Interior.ColorIndex = noColor Then
noColorCells = noColorCells + 1
End If
Next cel
Debug.Print "There are " & noColorCells & " non colored cells."
.Cells(startRow - 1, endCol + 2).Value = "Start Date"
.Cells(startRow - 1, endCol + 3).Value = "End Date"
'reDim the array to fit the colored cells
ReDim tDates(1 To noColorCells + 1)
i = 1 'index starts at 1, so set this to 1
For k = startRow To endRow
For o = startCol To endCol
If .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) = "" Then
.Cells(k, endCol + 2).Value = .Cells(k, o).Value
ElseIf .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) Then
i = i + i
.Cells(k, endCol + 3).Value = .Cells(k, o).Value
End If
' i = i + 1
Next o
i = i + 1
Next k
End With
MsgBox ("Done!")
End Sub
此子将找到任何有色细胞的地址。如果您可以通过查找表中彩色行的开始和结束来解释更多的含义。我可以调整这个。你可以发布样品表的图像吗?
This sub will find the addresses of any colored cells. If you can explain more what you mean by "locate the beginning and the end of coloured rows in a table." I can tweak this. Can you post an image of a sample table maybe?
编辑:按照下面的讨论,如果表中没有总是有数据,请尝试这样做,但是您需要彩色单元格的列:
Per discussion below, try this in case there's not always data in the table, but you want the columns of the colored cells:
Sub findColoredBGCells()
Dim startRow As Integer, endRow As Integer, i As Integer, k As Integer, startCol As Integer, endCol As Integer
Dim cellColor As String, noColor As String
Dim ws As Worksheet
Set ws = ActiveSheet
noColor = -4142
With ws
'Get the starting row
startRow = .Cells(1, 1).End(xlDown).Row
endRow = .Cells(startRow, 1).End(xlDown).Row
' Since we know where the names start and end (less ONE for the "Names" part), let's count how many names we have
Dim noNames As Integer
noNames = endRow - startRow
If Not IsEmpty(.Cells(1, 1)) Then ' Get the first used column with data
startCol = 1
ElseIf IsEmpty(.Cells(1, 1)) Then
startCol = .Cells(1, 1).End(xlToRight).Column
End If
endCol = .Cells(1, startCol).End(xlToRight).Column
'Now we have our range, let's use it to loop for blank cells, and add those to an array
Dim coloredCells() As Variant
ReDim coloredCells(1 To noNames, 2)
Dim rng As Range, cel As Range
Set rng = .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
'rng.Select
'Now, count how many cells are not blank background
Dim cnt As Integer, celRow As Integer, lastCelRow As Integer
i = 1
lastCelRow = 2
For Each cel In rng
cel.Select
celRow = cel.Row
If cel.Row <> lastCelRow Then 'This is so we can change the first dimension in the array
k = k + 1
coloredCells(k, 0) = .Cells(cel.Row, 1).Value
i = 1
' i = i + 1
End If
If cel.Interior.ColorIndex <> noColor Then
cnt = cnt + 1
If i > 2 Then i = 2 'Since it's only two dimensions we need, only go up to '1'
' ReDim Preserve coloredCells(noNames, i) 'resize the array to hold the new column
coloredCells(k, i) = .Cells(1, cel.Column).Value
i = i + 1
End If
lastCelRow = celRow
Next cel
For k = 1 To UBound(coloredCells)
Debug.Print coloredCells(k, 0) & " Start Date: " & coloredCells(k, 1) & ", end date: " & coloredCells(k, 2) & "."
.Cells(2 + k, 2).Value = coloredCells(k, 1)
.Cells(2 + k, 3).Value = coloredCells(k, 2)
Next k
End With
MsgBox ("Done!")
End Sub
这篇关于Excel VBA - 查找彩色行的开头和结尾的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!