Új hozzászólás Aktív témák

• #52466 F1DO senior tag F1DO #52461

  Új Válasz 2024-04-11 13:36:16 #52466

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  F1DO

  senior tag

  válasz F1DO #52461 üzenetére

  Végül kb megoldottam magam egy vba makró modullal:

  Sub Szines_kereso()
  Dim ws As Worksheet
  Dim xRg As Range
  Dim xFRg As Range
  Dim xStrAddress As String
  Dim xVrt As Variant
  Dim cellaszin As Long
  ' Munkalap inicializálása
  Set ws = ThisWorkbook.Sheets("Munkalap")
  Do
  xVrt = Application.InputBox(prompt:="Keresés: (Kilépéshez hagyja üresen és kattintson az OK-ra) ", Title:="Keresőablak találati színezéssel")
  If xVrt <> "" Then
  Set xFRg = ActiveSheet.Cells.Find(what:=xVrt)
  
  If xFRg Is Nothing Then
  MsgBox prompt:="A keresett érték nem található", Title:="Keresőablak találati színezéssel"
  Exit Sub
  End If
  xStrAddress = xFRg.Address
  Set xRg = xFRg
  Do
  Set xFRg = ActiveSheet.Cells.FindNext(After:=xFRg)
  Set xRg = Application.Union(xRg, xFRg)
  Loop Until xFRg.Address = xStrAddress
  If xRg.Count > 0 Then
  cellaszin = xRg.Interior.ColorIndex
  xRg.Interior.ColorIndex = 8
  ws.Rows(xRg.Row).Select ' Ha találtunk valamit, ugorjunk a megtalált cella sorához
  xRsp = MsgBox(prompt:="Akarja törölni a talált cella színezését?", Title:="Keresőablak találati színezéssel", Buttons:=vbQuestion + vbOKCancel)
  If xRsp = vbOK Then xRg.Interior.ColorIndex = cellaszin 'cella háttérszín visszaállítása
  End If
  
  End If
  Loop Until xVrt = "" ' Do ciklus záróeleme
  End Sub

Új hozzászólás Aktív témák