|
楼主 |
发表于 2020-4-27 12:34
|
显示全部楼层
- Sub 有色周围单元格()
- Dim sh As Worksheet, rgData As Range, rgFind As Range, strFind As String
- Dim lngRow_Min As Long, lngRow_Max As Long, lngCol_Min As Long, lngCol_Max As Long
- Dim lngRow As Long, arrResult As Variant, strFirstAddress As String
-
- Set sh = Sheets("suiji")
- lngRow = sh.Range("A" & Rows.Count).End(xlUp).Row
- Set rgData = sh.Range("A1:I" & lngRow)
-
- strFind = "4"
- lngRow_Min = rgData.Row
- lngRow_Max = rgData.Rows.Count - rgData.Row + 1
- lngCol_Min = rgData.Column
- lngCol_Max = rgData.Columns.Count - rgData.Column + 1
-
- lngRow = rgData.Rows.Count * rgData.Columns.Count
- ReDim arrResult(1 To lngRow, 1 To 9)
- lngRow = 1
- With rgData
- Set rgFind = .Find(strFind, LookIn:=xlValues)
- If Not rgFind Is Nothing Then
- strFirstAddress = rgFind.Address
- Do
- If rgFind.Interior.ColorIndex = 3 Then
- GetValByRange rgFind, arrResult, lngRow, lngRow_Min, lngRow_Max, lngCol_Min, lngCol_Max
- lngRow = lngRow + 1
- End If
- Set rgFind = .FindNext(rgFind)
- Loop While rgFind.Address <> strFirstAddress And Not (rgFind Is Nothing)
- End If
- End With
-
- sh.Range("U2").Resize(lngRow, 9) = arrResult
-
- End Sub
- Function GetValByRange(rgCentre As Range, arrReturn As Variant, lngCurRow As Long, lngRow_Min As Long, lngRow_Max As Long, lngCol_Min As Long, lngCol_Max As Long)
- Dim lngRow As Long, lngCol As Long
-
- lngRow = rgCentre.Row
- lngCol = rgCentre.Column
-
- arrReturn(lngCurRow, 1) = lngRow
-
- If lngRow > lngRow_Min Then arrReturn(lngCurRow, 3) = rgCentre.Offset(-1, 0).Value '上
- If lngRow < lngRow_Max Then arrReturn(lngCurRow, 7) = rgCentre.Offset(1, 0).Value '下
- If lngCol > lngCol_Min Then arrReturn(lngCurRow, 5) = rgCentre.Offset(0, -1).Value '左
- If lngCol < lngCol_Max Then arrReturn(lngCurRow, 6) = rgCentre.Offset(0, 1).Value '右
-
- If lngRow > lngRow_Min And lngCol > lngCol_Min Then arrReturn(lngCurRow, 2) = rgCentre.Offset(-1, -1).Value '左上
- If lngRow > lngRow_Min And lngCol < lngCol_Max Then arrReturn(lngCurRow, 4) = rgCentre.Offset(-1, 1).Value '右上
- If lngRow < lngRow_Max And lngCol > lngCol_Min Then arrReturn(lngCurRow, 9) = rgCentre.Offset(1, -1).Value '左下
- If lngRow < lngRow_Max And lngCol < lngCol_Max Then arrReturn(lngCurRow, 8) = rgCentre.Offset(1, 1).Value '右下
-
- End Function
复制代码 |
评分
-
1
查看全部评分
-
|