macro per ricerca e copia cartella excel

Question

Buon giorno,

cerco il vostro aiuto per una cosa sotto certi aspetti banale...

Allora ho un foglio Excel con una colonna (la A) contenente questi dati :

PIPPO
PLUTO
PAPERINO
TOPOLINO
COMO
MILANO
LONDRA
PARIGI
COMO
TORINO
NAPOLI

Come creo una macro che nell'ordine mi trovi la cella che contenga il dato (stringa) Como, copi in un'altra posizione le celle successive a questo dato (Milano, Londra, Parigi) fino a quando trova nuovamente la cella che contenga il dato (stringa) Como e mi elimini le celle successive (Torino, Napoli).

Spero di essere stato preciso nella domanda e ringrazio in anticipo chi mi aiuterà a risolvere quello che per me è diventato un grattacapo...

Answer 1

Ciao Pietro,

cerco il vostro aiuto per una cosa sotto certi aspetti banale...

Allora ho un foglio Excel con una colonna (la A) contenente questi dati :

PIPPO

PLUTO

PAPERINO

TOPOLINO

COMO

MILANO

LONDRA

PARIGI

COMO

TORINO

NAPOLI

Come creo una macro che nell'ordine mi trovi la cella che contenga il dato (stringa) Como, copi in un'altra posizione le celle successive a questo dato (Milano, Londra, Parigi) fino a quando trova nuovamente la cella che contenga il dato (stringa) Como e mi elimini le celle successive (Torino, Napoli).

Spero di essere stato preciso nella domanda e ringrazio in anticipo chi mi aiuterà a risolvere quello che per me è diventato un grattacapo...

• 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 srcRng As Range, srcRng2 As Range, destRng As Range

    Dim startRng As Range, endRng As Range

    Dim copyRng As Range

    Dim Res As Variant

    Dim sMsg As String, sTitle As String

    Dim iButtons As Long

    Dim LRow As Long, iRow As Long, jRow As Long

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

    Const sDestinazione As String = "C1"                   '<<=== Modifica

    Res = Application.InputBox( _

          Prompt:="Immetti la  stringa di interesse", _

          Title:="CHIAVE di RICERCA", _

          Type:=2)

    If Res = False Then

      sMsg = "Non hai fornito una stringa da ricercare." _

                     & vbNewLine _

                     & vbNewLine _

                     & "MACRO TERMINATA!"

             iButtons = vbInformation

             sTitle = "REPORT"

             GoTo XIT

    End If

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

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

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

        Set destRng = .Range(sDestinazione)

    End With

    Set startRng = srcRng.Find(What:=Res, _

                               LookIn:=xlValues, _

                               LookAt:=xlWhole, _

                               SearchOrder:=xlByRows, _

                               SearchDirection:=xlNext, _

                               MatchCase:=False)

    If startRng Is Nothing Then

        sMsg = "L'espressione " & Res _

               & " non è stata trovata nell'intervallo " _

               & srcRng.Address(0, 0)

        sTitle = "RICERCA FALLITA"

        iButtons = vbCritical

        GoTo XIT

    End If

    iRow = startRng.Row

    With SH

        Set srcRng2 = .Range("A" & iRow + 1).Resize(LRow - iRow)

        Set endRng = srcRng2.Find(What:=Res, _

                           LookIn:=xlValues, _

                           LookAt:=xlWhole, _

                           SearchOrder:=xlByRows, _

                           SearchDirection:=xlNext, _

                           MatchCase:=False)

        If endRng Is Nothing Then

            sMsg = "L'espressione " & Res _

                   & " è stata trovata solo una volta nell'intervallo " _

                   & srcRng.Address(0, 0)

            sTitle = "RICERCA FALLITA"

            iButtons = vbCritical

            GoTo XIT

        End If

         jRow = endRng.Row

        Set copyRng = .Range(startRng, endRng)

    End With

    copyRng.Copy Destination:=destRng

    sMsg = "L'intervallo " & copyRng.Address(0, 0) _

    & " è stato copiato nell'intervallo " _

    & destRng.Resize(copyRng.Rows.Count).Address(0, 0)

    sTitle = "INTERVALLO COPIATO!"

    iButtons = vbInformation

    srcRng.Offset(jRow).Resize(LRow - jRow).ClearContents

XIT:

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=iButtons, _

         Title:=sTitle)

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    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

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    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

Potresti scaricare il mio file di prova Pietro20180105.xlsm

===

Regards,

Norman