Ciao Fabio,
Errore run-time 1004
Impossibile impostare colore per classe Interior
e sul codice mi si evidenzia:
If Not FoundCells Is Nothing Then
Intersect(FoundCells.EntireRow, .UsedRange). _
Interior.Color = IIf(bCancella, xlNone, iSecondoColore)
If Not bTrovato Then
Intersect(FoundCells(1).EntireRow, .UsedRange). _
Interior.Color = IIf(bCancella, xlNone, iPrimoColore)
Quello in grassetto è ciò che mi si evidenzia
Grazie
Fabio
Questo si verifica quando inserisco la password per proteggere il foglio. Ma si riscontra su tutti i fogli protetti
Questo problema è dovuto al fatto che i fogli sono protetti e, essendo la mia sfera di cristallo ancora in attesa della riparazione, non ho modificato il mio codice per gestire questa possibilità non precedentemente rivelata :-)
Per superare il problema, sostituisci il codice nel modulo standard con la seguente versione in cui le modifiche sono evidenziate in grassetto:
'=========>>
Option Explicit
Public FindWhat As Variant
Public sMsg As String
Public sTitle As String
Public iButtons As Long
Public Const iPrimoColore As Long = vbYellow '<<=== Modifica
Public Const iSecondoColore As Long = vbGreen '<<=== Modifica
'--------->>
Public Sub Tester()
Call CercaTesto
End Sub
'--------->>
Public Sub CercaTesto(Optional bCancella As Boolean)
Dim WB As Workbook
Dim SH As Worksheet
Dim SearchRange As Range
Dim FoundCells As Range
Dim FoundCell As Range
Dim bTrovato As Boolean
Dim TextToFind As Variant
Dim rngRicerca As Range
Dim i As Long
Const sPassword As String = "PIPPO" '<<=== Modifica
If Not bCancella Then
FindWhat = Application.InputBox( _
Prompt:="Inserisci Cognome e Nome!!", _
Title:="COGNOME E NOME", _
Type:=2)
If FindWhat = False Then
sMsg = "Hai cancellato!"
sTitle = "CODICE TERMINATO!"
iButtons = vbCritical
GoTo XIT
ElseIf FindWhat = vbNullString Then
sMsg = "Non hai immesso un nome!"
sTitle = "CODICE TERMINATO!"
iButtons = vbCritical
GoTo XIT
End If
End If
Set WB = ThisWorkbook
For Each SH In WB.Sheets
With SH
Set SearchRange = .UsedRange
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If Not FoundCells Is Nothing Then
On Error GoTo XIT
.Unprotect Password:=sPassword
Intersect(FoundCells.EntireRow, .UsedRange). _
Interior.Color = IIf(bCancella, xlNone, iSecondoColore)
If Not bTrovato Then
Intersect(FoundCells(1).EntireRow, .UsedRange). _
Interior.Color = IIf(bCancella, xlNone, iPrimoColore)
bTrovato = True
End If
.Protect Password:=sPassword
End If
End With
On Error GoTo 0
Next SH
If bTrovato Then
sMsg = "Finito!"
If bCancella Then sMsg = sMsg _
& vbNewLine _
& "Lo sfondo di ogni cella che contiene il testo " _
& FindWhat & "è stato cancellato"
sTitle = "REPORT"
iButtons = vbInformation
Else
sMsg = "Il nome " & FindWhat & " non è stato trovato!"
sTitle = "REPORT"
iButtons = vbCritical
End If
XIT:
If Err.Number <> 0 Then
SH.Protect Password:=sPassword
End If
FindWhat = vbNullString
Call MsgBox( _
Prompt:=sMsg, _
Buttons:=iButtons, _
Title:=sTitle)
End Sub
'--------->>
Public Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = _
vbTextCompare) As Range
'\ Chip Pearson http://www.cpearson.com/excel/findall.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, _
BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, _
BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
'<<=========
===
Regards,
Norman
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
