Question

我有一个我无法解决的问题。问题在于问题。我想要的很简单：

从第5行扫描col Q到最后一行（最后一行值在单元格＆＃34; AL1＆＃34;）如果有＆＃34; *＆＃34; （符号存储在单元格中＃34; AK2＆＃34;）在Q行中。然后在该行中双击下划线单元格A到AF，继续向下扫描直到最后一行。

    Sub Reformat()

    Dim SrchRng3 As Range
    Dim c3 As Range, f As String

   Set SrchRng3 = ActiveSheet.Range("Q5",          ActiveSheet.Range("Q100000").End(xlUp))
Set c3 = SrchRng3.Find(Range("ak2"), LookIn:=xlValues)
If Not c3 Is Nothing Then
    f = c3.Address
    Do
        With ActiveSheet.Range("A" & c3.Row & ":AF" & c3.Row)
        Range("A" & c3.Row & ":AF" & c3.Row).Select
                .Borders (xlEdgeBottom)
                .LineStyle = xlDouble
                .ThemeColor = 4
                .TintAndShade = 0.399945066682943
                .Weight = xlThick
        End With
        Set c3 = SrchRng3.FindNext(c3)
    Loop While c3.Address <> f
End If
End Sub

Answer 1

这是你在尝试什么？我已对代码进行了评论，因此您不应该对其进行理解。如果您仍然这样做或者您收到错误，请告诉我：）

Sub Reformat()
    Dim rng As Range
    Dim aCell As Range, bCell As Range
    Dim ws As Worksheet
    Dim lRow As Long

    '~~> Change as applicable. Do not use Activesheet.
    '~~> The Activesheet may not be the sheet you think
    '~~> is active when the macro runs
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Find last row in Col Q
        lRow = .Range("Q" & .Rows.Count).End(xlUp).Row

        '~~> Set your Find Range
        Set rng = .Range("Q5:Q" & lRow)

        '~~> Find (When searching for "*" after add "~" before it.
        Set aCell = rng.Find(What:="~" & .Range("AK2"), LookIn:=xlFormulas, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bCell = aCell

            '~~> Create the necessary border that you are creating
            With .Range("A" & aCell.Row & ":AF" & aCell.Row).Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .ThemeColor = 4
                .TintAndShade = 0.399945066682943
                .Weight = xlThick
            End With

            Do
                Set aCell = rng.FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do

                    '~~> Create the necessary border that you are creating
                    With .Range("A" & aCell.Row & ":AF" & aCell.Row).Borders(xlEdgeBottom)
                        .LineStyle = xlDouble
                        .ThemeColor = 4
                        .TintAndShade = 0.399945066682943
                        .Weight = xlThick
                    End With
                Else
                   Exit Do
                End If
            Loop
        End If
    End With
End Sub

<强>截图

Answer 2

AutoFilter版本：

Option Explicit

Public Sub showSymbol()
    Dim lRow As Long, ur As Range, fr As Range

    Application.ScreenUpdating = False
    With ActiveSheet
        lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
        Set ur = .Range("A5:AF" & lRow)
        Set fr = ur.Offset(1).Resize(ur.Rows.Count - 1)

        ur.Columns(17).AutoFilter Field:=1, Criteria1:="~" & .Range("AK2").Value2
        fr.Borders(xlEdgeBottom).LineStyle = xlDouble
        fr.Borders(xlInsideHorizontal).LineStyle = xlDouble
        ur.AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

要为一个特定工作表的每个OnCahange事件执行它，请将其添加到其VBA模块中：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .CountLarge = 1 Then 'run only if one cell was updated

            'restrict the call to column Q only, and if the new value is same as cell AK2
            If .Column = 17 And .Value2 = Me.Range("AK2").Value2 Then showSymbol

        End If
    End With
End Sub

要对文件中的所有工作表执行此操作，请将其添加到ThisWorkbook的VBA模块：

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    If Target.CountLarge = 1 Then If Target.Column = 17 Then showSymbol

End Sub

如果col q = *，则宏双下划线范围

2 个答案: