Question

我有一些编码循环显示策略编号列表，然后在整个工作簿中搜索匹配的策略编号，粗体显示原始列表中找到的所有匹配项。编码工作正常，但如果可能，我想做的是打印＆＃39;匹配值的地址/单元格位置。例如，如果策略编号1位于工作表3，单元格a1上，那么这将显示在新的空白工作表上。我确信这可以使用字典和print.debug函数完成，但我想尽可能避免使用字典。希望这是有道理的！

 Sub HighlightMatches()

 Application.ScreenUpdating = True
 Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long,bln   As Boolean

 iRowL = Sheets(3).Cells(Rows.Count, "P").End(xlUp).row

 For iRow = 1 To iRowL

 If Not IsEmpty(Cells(iRow, 16)) Then
 For iSheet = ActiveSheet.Index + 1 To Worksheets.Count
            bln = False
            var = Application.match(Cells(iRow, 16).Value, Worksheets(iSheet).Columns(16), 0)

            If Not IsError(var) Then
               bln = True
               Exit For
            End If
         Next iSheet
      End If


     ' The below would 'print' all matches and an offset value to a new Worksheet.
      If bln = False Then
         Cells(iRow, 16).Font.Bold = False
         Else
         Cells(iRow, 16).Font.Bold = True
      End If
   Next iRow
Application.ScreenUpdating = True

End Sub

Answer 1

这样就可以了：

Option Explicit

Sub HighlightMatches()
Dim OriginalWS As Worksheet, NewListWorksheet As Worksheet, ws As Worksheet
Dim Cel As Range, Rng As Range, rSearchCell As Range

Set OriginalWS = ActiveSheet
Set Rng = Columns("P:P").SpecialCells(xlCellTypeConstants, 23)

For Each Cel In Rng
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> OriginalWS.Name And ws.Name <> "Search List" Then
            On Error Resume Next
            Set rSearchCell = ws.Columns("P:P").Find(What:=Cel.Value, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
            On Error GoTo 0
            If Not rSearchCell Is Nothing Then
                Cel.Font.Bold = True
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Search List"
                On Error Resume Next
                Set NewListWorksheet = ActiveSheet
                On Error GoTo 0
                If Not NewListWorksheet Is Nothing Then
                    NewListWorksheet.Range("A" & NewListWorksheet.Range("A" & NewListWorksheet.Rows.Count).End(xlUp).Row + 1).Value = Cel.Value
                    Else
                    Set NewListWorksheet = Sheets.Add.Name = "Search List"
                    NewListWorksheet.Range("A1").Value = "Search results"
                    NewListWorksheet.Range("A1").Font.Bold = True
                    NewListWorksheet.Range("A2").Value = Cel.Value
                End If
                Else
                Cel.Font.Bold = False
            End If
        End If
        Set rSearchCell = Nothing 'Clear Cel
    Next
Next

End Sub

VBA到＆＃39;打印＆＃39;匹配搜索结果到新的WS

1 个答案: