MACRO VBA EXCEL

Question

Buonasera a tutti,

ho bisogno di un consiglio di qualche esperto (io purtroppo sono completamente digiuno di VBA). Questa la macro che ho scritto è questa

Sub SpostaTaskCompletati()

  Dim xRg As Range

  Dim T As Long

  Dim R As Long

T = Worksheets("DASHBOARD").UsedRange.Rows.Count

  Set xRg = Worksheets("DASHBOARD").Range("H1:H" & T)

  On Error Resume Next

  Application.ScreenUpdating = False

  For R = 1 To xRg.Count

     If CStr(xRg(R).Value) = "COMPLETATO" Then

     xRg(R).EntireRow.Delete

        If CStr(xRg(R).Value) = "COMPLETATO" Then

        R = R - 1

        End If

     End If

Next

Application.ScreenUpdating = True

End Sub

La macro funziona correttamente però avrei bisogno di implementarla facendo in modo che si colleghi ad una nuova cartella di lavoro. In pratica la macro dovrebbe poter fare questo (ovviamente io l'avvierei dalla cartella 1):

1. vai nel foglio DASHBOARD della Cartella 1;
2. cerca valore COMPLETATO nella colonna H;
3. se trovi COMPLETATO cancella intera riga;
4. vai nel foglio DASHBOARD2 della Cartella 2;
5. cerca valore COMPLETATO nella colonna H;
6. se trovi COMPLETATO cancella intera riga;

E' fattibile?

Grazie in anticipo.

Answer 1

Ciao Andrea,

Si devo sbloccare i fogli TASK e anche i fogli ARCHIVIO TASK COMPLETATI di entrambe le cartelle.

La macro per operare apre il secondo file, può anche chiuderlo?

Allora, sostituisci il codice con qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub SpostaTaskCompletati()

Dim WB1 As Workbook, WB2 As Workbook 

Dim SH1 As Worksheet, SH2 As Worksheet 

Dim destSH1 As Worksheet, destSH2 As Worksheet 

Dim Rng1 As Range, Rng2 As Range 

Dim destRng As Range, destRng2 As Range 

Dim rngDelete As Range, rngDelete2 As Range 

Dim rCell As Range 

Dim UR As Long, UR2 As Long 

Const sCartella1 As String = **"TT SEGRETERIA.xlsm"** 

Const sCartella2 As String = **"TT DIVISIONI.xlsm"**          

Const sFoglio1 As String = **"TASK"**                        

Const sFoglio2 As String = **"TASK"**

Const sFoglio\_Destinazione As String = **"ARCHIVIO TASK COMPLETATI"** 

Const sFoglio2\_Destinazione As String = **"ARCHIVIO TASK COMPLETATI"**

Const sParola As String = **"COMPLETATO"** 

Const sPassword1 As String = **"Pippo"                            '<<=== Modifica** 

Const sPassword2 As String = **"Pluto"                            '<<=== Modifica** 

Set WB1 = Workbooks(sCartella1)      

On Error GoTo XIT 

Application.ScreenUpdating = False 

If IsWorkbookOpen(sCartella2) Then 

    Set WB2 = Workbooks(sCartella2) 

Else 

    Set WB2 = Workbooks.Open(WB1.Path & Application.PathSeparator & sCartella2) 

End If 

With WB1 

    Set SH1 = .Sheets(sFoglio1) 

    Set destSH1 = .Sheets(sFoglio\_Destinazione) 

End With 

With WB2 

    Set SH2 = .Sheets(sFoglio2) 

    Set destSH2 = .Sheets(sFoglio2\_Destinazione) 

End With 

With SH1 

    UR = .Range("H" & .Rows.Count).End(xlUp).Row 

    Set Rng1 = .Range("H1:H" & UR) 

    .Unprotect Password:=sPassword1 

End With 

With SH2 

    UR = .Range("H" & .Rows.Count).End(xlUp).Row 

    Set Rng2 = .Range("H1:H" & UR) 

    .Unprotect Password:=sPassword2 

End With 

destSH1.Unprotect Password:=sPassword1 

destSH2.Unprotect Password:=sPassword2 

For Each rCell In Rng1.Cells 

    With rCell 

        If UCase(.Value) = sParola Then 

            If rngDelete Is Nothing Then 

                Set rngDelete = rCell 

            Else 

                Set rngDelete = Union(rngDelete, rCell) 

            End If 

        End If 

    End With 

Next rCell 

For Each rCell In Rng2.Cells 

    With rCell 

        If UCase(.Value) = sParola Then 

            If rngDelete2 Is Nothing Then 

                Set rngDelete2 = rCell 

            Else 

                Set rngDelete2 = Union(rngDelete2, rCell) 

            End If 

        End If 

    End With 

Next rCell 

If Not rngDelete Is Nothing Then 

    With WB1.Sheets(sFoglio\_Destinazione) 

        UR = .Range("H" & .Rows.Count).End(xlUp).Row 

        Set destRng = .Range("A" & UR + 1) 

    End With 

    Intersect(SH1.Columns("A:M"), rngDelete.EntireRow).Copy Destination:=destRng 

    rngDelete.EntireRow.Delete 

End If 

If Not rngDelete2 Is Nothing Then 

    With WB2.Sheets(sFoglio2\_Destinazione) 

        UR = .Range("H" & .Rows.Count).End(xlUp).Row 

        Set destRng2 = .Range("A" & UR + 1) 

    End With 

    Intersect(SH2.Columns("A:M"), rngDelete2.EntireRow).Copy Destination:=destRng2 

    rngDelete2.EntireRow.Delete 

End If 

SH1.Protect Password:=sPassword1 

SH2.Protect Password:=sPassword2 

destSH1.Protect Password:=sPassword1 

destSH2.Protect Password:=sPassword2 

WB1.Save

WB2.Close SaveChanges:=True

Call MsgBox(Prompt:="Fatto", \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT") 

XIT:

Application.ScreenUpdating = True 

End Sub

'-------->>

Public Function IsWorkbookOpen(WBName As String) As Boolean

On Error Resume Next 

IsWorkbookOpen = CBool(Len(Excel.Application.Workbooks(WBName).Name)) 

End Function

'<<========

===

Regards,

Norman

Answer 2

Ciao Andrea,

Buonasera Norman. Funziona  tutto.

Grazie mille  soprattutto per  la  pazienza 😉.

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

Per chiudere questo thread, e per aiutare altri con un simile problema, ti chiederei gentilmente di contrassegnare il codice come Risposta.

Alla prossima.

===

Regards,

Norman

Answer 3

Ciao Andrea,

la formula funziona perfettamente. Grazie mille!!!! Provandola però mi sono accorto di dover fare una modifica. Quando la macro va ad incollare nel foglio 2 deve incollare solo le colonne da A ad M. E' Possibile?

Certo, prova la seguente modifica del codice:

'========>>

Option Explicit

'-------->>

Public Sub SpostaTaskCompletati()

Dim WB1 As Workbook, WB2 As Workbook 

Dim SH1 As Worksheet, SH2 As Worksheet 

Dim destSH1 As Worksheet, destSH2 As Worksheet 

Dim Rng1 As Range, Rng2 As Range 

Dim destRng As Range, destRng2 As Range 

Dim rngDelete As Range, rngDelete2 As Range 

Dim rCell As Range 

Dim UR As Long, UR2 As Long 

Const sCartella1 As String = "**Andrea20210616.xlsm"             '<<=== Modifica** 

Const sCartella2 As String = **"Andrea20210616.xlsx"             '<<=== Modifica** 

Const sFoglio1 As String = **"DASHBOARD"                         '<<=== Modifica** 

Const sFoglio2 As String = **"DASHBOARD2"                        '<<=== Modifica** 

Const sFoglio\_Destinazione As String = **"Foglio2"              '<<=== Modifica** 

Const sFoglio2\_Destinazione As String = **"Foglio2"             '<<=== Modifica** 

Const sParola As String = **"COMPLETATO"** 

Set WB1 = Workbooks(sCartella1) 

If IsWorkbookOpen(sCartella2) Then 

    Set WB2 = Workbooks(sCartella2) 

Else 

    Set WB2 = Workbooks.Open(WB1.Path & Application.PathSeparator & sCartella2) 

End If 

Set SH1 = WB1.Sheets(sFoglio1) 

Set SH2 = WB2.Sheets(sFoglio2) 

With SH1 

    UR = .Range("H" & .Rows.Count).End(xlUp).Row 

    Set Rng1 = .Range("H1:H" & UR) 

End With 

With SH2 

    UR = .Range("H" & .Rows.Count).End(xlUp).Row 

    Set Rng2 = .Range("H1:H" & UR) 

End With 

For Each rCell In Rng1.Cells 

    With rCell 

        If UCase(.Value) = sParola Then 

            If rngDelete Is Nothing Then 

                Set rngDelete = rCell 

            Else 

                Set rngDelete = Union(rngDelete, rCell) 

            End If 

        End If 

    End With 

Next rCell 

For Each rCell In Rng2.Cells 

    With rCell 

        If UCase(.Value) = sParola Then 

            If rngDelete2 Is Nothing Then 

                Set rngDelete2 = rCell 

            Else 

                Set rngDelete2 = Union(rngDelete2, rCell) 

            End If 

        End If 

    End With 

Next rCell 

If Not rngDelete Is Nothing Then 

    With WB1.Sheets("Foglio2") 

        UR = .Range("H" & .Rows.Count).End(xlUp).Row 

        Set destRng = .Range("A" & UR + 1) 

    End With 

    Intersect(SH1.Columns("A:M"), rngDelete.EntireRow).Copy Destination:=destRng 

    rngDelete.EntireRow.Delete 

End If 

If Not rngDelete2 Is Nothing Then 

    With WB2.Sheets("Foglio2") 

        UR = .Range("H" & .Rows.Count).End(xlUp).Row 

        Set destRng2 = .Range("A" & UR + 1) 

    End With 

    Intersect(SH2.Columns("A:M"), rngDelete2.EntireRow).Copy Destination:=destRng2 

    rngDelete2.EntireRow.Delete 

End If 

End Sub

'-------->>

Public Function IsWorkbookOpen(WBName As String) As Boolean

On Error Resume Next 

IsWorkbookOpen = CBool(Len(Excel.Application.Workbooks(WBName).Name)) 

End Function

'<<========

===

Regards,

Norman

Answer 4

Buongiorno Norman. Come sempre grazie mille per la disponibilità.

Ho provato la tua macro e ho questi problemi:

1. se Cartel2 non è aperto il tutto non funziona (avrei bisogno che lavorasse anche se il file 2 è chiuso);
2. in Cartel2 cancella correttamente la riga ma in Cartel1 no.

Poi ho dimenticato io di descriverti la macro. La riporto di seguito:

1. vai nel foglio foglio 1 della Cartella 1;
2. cerca valore COMPLETATO nella colonna H;
3. se trovi COMPLETATO cancella intera riga;
4. copia intera riga in foglio 2 della Cartella 1;
5. vai nel foglio 1 della Cartella 2;
6. cerca valore COMPLETATO nella colonna H;
7. se trovi COMPLETATO cancella intera riga;
8. copia intera riga in foglio 2 della Cartella 2;

Grazie

Andrea

Answer 5

Ciao Andrea,

ho bisogno di un consiglio di qualche esperto (io purtroppo sono completamente digiuno di VBA). Questa la macro che ho scritto è questa

Sub SpostaTaskCompletati()

 

  Dim xRg As Range

  Dim T As Long

  Dim R As Long

 

T = Worksheets("DASHBOARD").UsedRange.Rows.Count

 

  Set xRg = Worksheets("DASHBOARD").Range("H1:H" & T)

  On Error Resume Next

  Application.ScreenUpdating = False

  For R = 1 To xRg.Count

     If CStr(xRg(R).Value) = "COMPLETATO" Then

     xRg(R).EntireRow.Delete

        If CStr(xRg(R).Value) = "COMPLETATO" Then

        R = R - 1

        End If

     End If

Next

Application.ScreenUpdating = True

End Sub

La macro funziona correttamente però avrei bisogno di implementarla facendo in modo che si colleghi ad una nuova cartella di lavoro. In pratica la macro dovrebbe poter fare questo (ovviamente io l'avvierei dalla cartella 1):

1. vai nel foglio DASHBOARD della Cartella 1;
2. cerca valore COMPLETATO nella colonna H;
3. se trovi COMPLETATO cancella intera riga;
4. vai nel foglio DASHBOARD2 della Cartella 2;
5. cerca valore COMPLETATO nella colonna H;
6. se trovi COMPLETATO cancella intera riga;

E' fattibile?

Grazie in anticipo.

Prova qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub SpostaTaskCompletati()

Dim WB1 As Workbook, WB2 As Workbook 

Dim SH1 As Worksheet, SH2 As Worksheet 

Dim Rng1 As Range, Rng2 As Range 

Dim rngDelete As Range, rngDelete2 As Range 

Dim rCell As Range 

Dim UR As Long, UR2 As Long 

Const sCartella1 As String = **"Cartel1.xlsm"             '<<=== Modifica** 

Const sCartella2 As String = **"Cartel2.xlsx"              '<<=== Modifica** 

Const sFoglio1 As String = **"DASHBOARD"             '<<=== Modifica** 

Const sFoglio2 As String = **"DASHBOARD2"           '<<=== Modifica** 

Const sParola As String = **"COMPLETATO"             '<<=== Modifica** 

Set WB1 = Workbooks(sCartella1) 

Set WB2 = Workbooks(sCartella2) 

Set SH1 = WB1.Sheets(sFoglio1) 

Set SH2 = WB2.Sheets(sFoglio2) 

With SH1 

    UR = .Range("H" & .Rows.Count).End(xlUp).Row 

    Set Rng1 = .Range("H1:H" & UR) 

End With 

With SH2 

    UR = .Range("H" & .Rows.Count).End(xlUp).Row 

    Set Rng2 = .Range("H1:H" & UR) 

End With 

For Each rCell In Rng1.Cells 

    With rCell 

        If UCase(.Value) = sParola Then 

            If rngDelete Is Nothing Then 

                Set rngDelete = rCell 

            Else 

                Set rngDelete = Union(rngDelete, rCell) 

            End If 

        End If 

    End With 

Next rCell 

For Each rCell In Rng2.Cells 

    With rCell 

        If UCase(.Value) = sParola Then 

            If rngDelete2 Is Nothing Then 

                Set rngDelete2 = rCell 

            Else 

                Set rngDelete2 = Union(rngDelete2, rCell) 

            End If 

        End If 

    End With 

Next rCell 

If Not rngDelete Is Nothing Then 

    rngDelete.EntireRow.Delete 

End If 

If Not rngDelete2 Is Nothing Then 

    rngDelete2.EntireRow.Delete 

End If 

End Sub

'<<========

===

Regards,

Norman