Cercare e sostituire parole doppie nella stessa cella ?

Question

buona sera,

è possibile cercare in una colonna, celle con la presenza di due testi uguali nella stessa cella ma con posizioni diverse e sostituirle con un testo univoco?

esempio:

cane cane gatto

cane gatto cane

con

cane gatto

Grazie dell'attenzione.

Pier Luigi

excel 2010

Answer 1

Ciao Pier Luigi,

è possibile cercare in una colonna, celle con la presenza di due testi uguali nella stessa cella ma con posizioni diverse e sostituirle con un testo univoco?

esempio:

cane cane gatto

cane gatto cane

con

cane gatto

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim sStr As String, aStr As String, bStr As String

    Dim sMsg As String

    Dim i As Long, iPos As Long, jPos As Long

    Dim iCtr As Long, iLen As Long, iButtons As Long

    Dim LRow As Long

    Dim Res As Variant

    Const sFoglio As String = "Foglio1"        '<<=== Modifica

    Res = Application.InputBox( _

          Prompt:="Immetti la parola dio interesse", _

          Title:="PAROLA DI RICERCA", _

          Default:="Cane", _

          Type:=2)

    If Res = False Then

        sMsg = "Hai Cancellato!"

        iButtons = vbCritical

        GoTo XIT

    ElseIf Res = vbNullString Then

        sMsg = "Non hai precisato una parola di ricerca!"

        iButtons = vbCritical

        GoTo XIT

    End If

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set Rng = .Range("A1:A" & LRow)

    End With

    iLen = Len(Res)

    For Each rCell In Rng.Cells

        With rCell

            If Not .HasFormula Then

                sStr = .Text

                iPos = InStr(1, sStr, Res, vbTextCompare)

                If CBool(iPos) Then

                    jPos = InStr(iPos + iLen, sStr, Res, vbTextCompare)

                End If

                If CBool(jPos) Then

                    iCtr = iCtr + 1

                    aStr = Left(sStr, jPos - 1)

                    bStr = Mid(sStr, jPos)

                    .Value = aStr & Replace(bStr, Res, vbNullString, jPos, -1, vbTextCompare)

                End If

            End If

        End With

    Next rCell

    sMsg = iCtr & " celle sono state modificate."

    iButtons = vbInformation

XIT:

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=iButtons, _

         Title:="REPORT")

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<=========

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

===

Regards,

Norman

Answer 2

CoaoPier Luigi,

Gentilissimo Norman buona sera,

Il codice proposto fa al caso mio.

Mi fa piacere che tu abbia risolto il problema e ti ringrazio per il cortese riscontro.

Per chiudere questo thread, vorrei chiederti gentilmente di contrassegnare la mia risposta come Risposta preferita. In questo modo, tu aiuterai anche coloro che potessero cercare soluzioni ai problemi simili negli archivi della Community.

    

===

Regards,

Norman

Answer 3

Gentilissimo Norman buona sera,

Il codice proposto fa al caso mio.

Grazie

Cordiali saluti

Pier Luigi