VBA 区间内“横向”判断, 查找及标示 ( 有详细步骤 )

leirongqin

On_fire 发表于 2023-1-8 11:55
老师好, 又要向您请教…如载图, 想做一个按钮, 1:选中单元格之后, 2:按了(Sub按钮), 再出代码结果, 请问 ...

那你把我那个工作表里面的代码全部转移到模块里面，名称你随便取一个。然后把所有Target改Selection并关联宏按钮就可以

leirongqin

Sub cz()
    Application.ScreenUpdating = False
    Dim arr, str$, a%, b%, x%, i%, j%, st As Range
    If Selection.Columns.Count > 1 Or Selection.Rows.Count > 1 Then Exit Sub
    If Selection.Value <> "" Then
    a = Selection.Row - 1
    b = Selection.Row
    x = Selection.Column + 1
    srt = Right(Selection.Value, 1)
    arr = Sheet1.UsedRange
        Set ls = Worksheets(1): zhao = False: n = 0
        Do While Not zhao
            If ls.Cells(a, 1).Borders(xlEdgeBottom).LineStyle = xlDot Or a = "8" Then
                n = n + 1
                If n = 1 Then
                    n = 0
                    a = a + 1
                    Do While Not zhao
                        If ls.Cells(b, 1).Borders(xlEdgeBottom).LineStyle = xlDot Or b = UBound(arr) Then
                            n = n + 1
                            If n = 1 Then
                                'Range("A" & a & ":AT" & b).Font.ColorIndex = 1
                                For i = a To b
                                    For j = x To 46
                                        If Right(arr(i, j), 1) = srt Then
                                            If st Is Nothing Then
                                                Set st = Cells(i, j)
                                            Else
                                                Set st = Union(st, Cells(i, j))
                                            End If
                                        End If
                                    Next
                                Next
                                If Not st Is Nothing Then
                                    st.Font.ColorIndex = 9
                                End If
                                zhao = Not zhao
                            End If
                        End If
                        b = b + 1
                        Loop
                        End If
                        End If
                        a = a - 1
                        Loop
                        End If
                        Application.ScreenUpdating = True
                        End Sub

这样就可以，加了个条件如果选择大于一行或一列，不筛选

On_fire

leirongqin 发表于 2023-1-8 14:26
这样就可以，加了个条件如果选择大于一行或一列，不筛选

再次感谢您的耐心指导…
这种多次的判断式, 我肯定写不出来

leirongqin

On_fire 发表于 2023-1-8 18:18
再次感谢您的耐心指导…
这种多次的判断式, 我肯定写不出来

老师级别这么高了，肯定也很厉害。只是没发时间去弄这些简单而已。后面发的代码，定义那边有个错误，是srt$，不是str$。你看下如果是用这个那就改一下吧，当然不改vba也是可以正常运行的

On_fire

leirongqin 发表于 2023-1-8 14:26
这样就可以，加了个条件如果选择大于一行或一列，不筛选

老师好,
请问可以把查找符及配对的字符的条件, 改成字典查找配对标示吗?
srt = Right(Selection.Value, 1)
If Right(arr(i, j), 1) = srt Then
*
比如是这样,  
Set d(srt) = CreateObject("scripting.dictionary")
因为发现了,
有配对不整.不完备的情况…
是有标示, 但少了一些, 会有漏标...

On_fire

leirongqin 发表于 2023-1-8 19:22
老师级别这么高了，肯定也很厉害。只是没发时间去弄这些简单而已。后面发的代码，定义那边有个错误，是 ...

我只是EH的铁粉…
只要稍为难一点的代码, 都写不出来…
因为经常溜达及回应, 现在的级别已经成为…EH铁杆

leirongqin

On_fire 发表于 2023-1-12 14:31
老师好,
请问可以把查找符及配对的字符的条件, 改成字典查找配对标示吗?
srt = Right(Selection.Value, ...

没觉得代码有问题，因为就一个字符查找，你要搞字典感觉有点大材小用，新附件改字典，你测试一下看看。有漏标的截图吗，数据区域是多少到多少。代码列数只能标记到第46列。

On_fire

leirongqin 发表于 2023-1-12 15:45
没觉得代码有问题，因为就一个字符查找，你要搞字典感觉有点大材小用，新附件改字典，你测试一下看看。有 ...

谢谢老师,

再请问,

If ls.Cells(a, 1).Borders(xlEdgeBottom).LineStyle = xlDot Or a ="8"

上面这句a = "8",

8是甚么意思? 提指行数最多吗?

每个区间最多行数的有15行

leirongqin

On_fire 发表于 2023-1-12 16:00
谢谢老师,再请问, If ls.Cells(a, 1).Borders(xlEdgeBottom).LineStyle = xlDot Or a ="8"上面这句a = "8", ...

这个是因为你上方9行是标题，所以向上找的时候然后到第8行还没找的单元格下边线，那么久返回。算找到区域顶部，接着运行代码。

leirongqin

On_fire 发表于 2023-1-12 16:00
谢谢老师,再请问, If ls.Cells(a, 1).Borders(xlEdgeBottom).LineStyle = xlDot Or a ="8"上面这句a = "8", ...

我这个代码的原理是，按你选定的单元格开始上下两个方向查找下标线。第一个do是向上找区间上坐标，第二个do是向下找区间下坐标