宏雙下劃線範圍如果col q = *

Question

我有一個問題，我無法解決。問題出在col Q.我想要的很簡單：

從第5行掃描列Q直到最後一行（最後一行值在單元格「AL1」中） 如果存在「*」（符號存儲在單元格「AK2」）在該行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

自動篩選版本：

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 

---

要對一個parti的每個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