Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2825|回复: 7

[已解决]改为高亮显示选中区域的行和列

[复制链接]
发表于 2014-1-6 14:56 | 显示全部楼层 |阅读模式
本帖最后由 过江龙 于 2014-1-7 09:54 编辑

以下代码是论坛中有位老师制作的高亮显示选中的单元格,我要想改为高亮显示选中区域的行和列,谢谢!
Option Explicit
Declare Function GetCursorPos _
        Lib "user32" ( _
        lpPoint As POINTAPI) _
        As Long
Type POINTAPI
    x As Long
    y As Long
End Type
Dim ChangeOn As Boolean
Dim OldRange As Range
Dim OldColorIndex As Integer
Dim blnStop As Boolean

Sub StopChange()
    On Error Resume Next
    If Not blnStop Then
        blnStop = True
    End If
End Sub
Sub ChangeColor()
Dim LngCurPos As POINTAPI
Dim NewRange As Range
    On Error Resume Next
    blnStop = False
    If ChangeOn Then
        Exit Sub
    Else
        ChangeOn = True
    End If
    Do
        If blnStop = True Then Exit Do
        GetCursorPos LngCurPos
        On Error Resume Next
        Set NewRange = ActiveWindow.RangeFromPoint(LngCurPos.x, LngCurPos.y)
        If Err <> 0 Then
            OldRange.Interior.ColorIndex = OldColorIndex
        Else
            If NewRange.Address <> OldRange.Address Then
                If OldRange Is Nothing Then
                Else
                    OldRange.Interior.ColorIndex = OldColorIndex
                End If
                OldColorIndex = NewRange.Interior.ColorIndex
                NewRange.EntireRow.Interior.ColorIndex = 16
            End If
            Set OldRange = NewRange
        End If
        On Error GoTo 0
        DoEvents
    Loop
    ChangeOn = False
End Sub

最佳答案
2014-1-6 17:44
  1. Sub ChangeColor()
  2.     Dim LngCurPos As POINTAPI
  3.     Dim NewRange As Range
  4.     On Error Resume Next
  5.     blnStop = False
  6.     If ChangeOn Then
  7.         Exit Sub
  8.     Else
  9.         ChangeOn = True
  10.     End If
  11.     Do
  12.         If blnStop = True Then Exit Do
  13.         GetCursorPos LngCurPos
  14.         On Error Resume Next
  15.         Set NewRange = ActiveWindow.RangeFromPoint(LngCurPos.x, LngCurPos.y)
  16.         If Err <> 0 Then
  17.             OldRange.Interior.ColorIndex = OldColorIndex
  18.         Else
  19.             If NewRange.Address <> OldRange.Address Then
  20.                 If OldRange Is Nothing Then
  21.                 Else
  22.                     'OldRange.Interior.ColorIndex = OldColorIndex
  23.                     With OldRange
  24.                         .EntireRow.Interior.ColorIndex = OldColorIndex
  25.                         .EntireColumn.Interior.ColorIndex = OldColorIndex
  26.                     End With
  27.                 End If
  28.                 OldColorIndex = NewRange.EntireRow.Interior.ColorIndex
  29.                 With NewRange
  30.                     .EntireColumn.Interior.ColorIndex = 16
  31.                     .EntireRow.Interior.ColorIndex = 16
  32.                 End With
  33.             End If
  34.             Set OldRange = NewRange
  35.         End If
  36.         On Error GoTo 0
  37.         DoEvents
  38.     Loop
  39.     ChangeOn = False
  40. End Sub
复制代码
发表于 2014-1-6 16:29 | 显示全部楼层
最好是上传附件,代码片断不好调试。
回复

使用道具 举报

 楼主| 发表于 2014-1-6 17:38 | 显示全部楼层
hwc2ycy 发表于 2014-1-6 16:29
最好是上传附件,代码片断不好调试。

好的,谢谢!附件如下: Book2.rar (11.45 KB, 下载次数: 10)
回复

使用道具 举报

发表于 2014-1-6 17:39 | 显示全部楼层
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.ColorIndex = xlNone
For Each r In Selection.Areas
    i1 = r(1).Address
    i2 = r(r.Cells.Count).Address
    Range(i1 & ":" & i2).EntireRow.Interior.ColorIndex = 5
    Range(i1 & ":" & i2).EntireColumn.Interior.ColorIndex = 5
Next
End Sub
回复

使用道具 举报

发表于 2014-1-6 17:44 | 显示全部楼层    本楼为最佳答案   
  1. Sub ChangeColor()
  2.     Dim LngCurPos As POINTAPI
  3.     Dim NewRange As Range
  4.     On Error Resume Next
  5.     blnStop = False
  6.     If ChangeOn Then
  7.         Exit Sub
  8.     Else
  9.         ChangeOn = True
  10.     End If
  11.     Do
  12.         If blnStop = True Then Exit Do
  13.         GetCursorPos LngCurPos
  14.         On Error Resume Next
  15.         Set NewRange = ActiveWindow.RangeFromPoint(LngCurPos.x, LngCurPos.y)
  16.         If Err <> 0 Then
  17.             OldRange.Interior.ColorIndex = OldColorIndex
  18.         Else
  19.             If NewRange.Address <> OldRange.Address Then
  20.                 If OldRange Is Nothing Then
  21.                 Else
  22.                     'OldRange.Interior.ColorIndex = OldColorIndex
  23.                     With OldRange
  24.                         .EntireRow.Interior.ColorIndex = OldColorIndex
  25.                         .EntireColumn.Interior.ColorIndex = OldColorIndex
  26.                     End With
  27.                 End If
  28.                 OldColorIndex = NewRange.EntireRow.Interior.ColorIndex
  29.                 With NewRange
  30.                     .EntireColumn.Interior.ColorIndex = 16
  31.                     .EntireRow.Interior.ColorIndex = 16
  32.                 End With
  33.             End If
  34.             Set OldRange = NewRange
  35.         End If
  36.         On Error GoTo 0
  37.         DoEvents
  38.     Loop
  39.     ChangeOn = False
  40. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2014-1-7 09:54 | 显示全部楼层
hwc2ycy 发表于 2014-1-6 17:44

谢谢老师!每次都是老师帮忙,真心的谢谢。
回复

使用道具 举报

 楼主| 发表于 2014-1-7 09:58 | 显示全部楼层
djyjysxxs 发表于 2014-1-6 17:39
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.ColorIndex = xlNone
Fo ...

谢谢版主,这个也不错。我只是想做一个加载宏并且可以随时取消与调用,这样方便。
回复

使用道具 举报

 楼主| 发表于 2014-1-7 15:14 | 显示全部楼层
hwc2ycy 发表于 2014-1-6 17:44

老师,顺便再问一下,这个代码是高亮显示是跟着鼠标走的,假如我想要选中单元格之后才高亮显示,代码又该怎么修改呢?
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 17:38 , Processed in 1.078935 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表