Macro per cancellare foglio e copiare contenuto da differenti files

Question

Ciao a tutt*.

Chiedo una mano a voi super esperti per finalizzare una vba.

Spiego prima cosa dovrebbe succedere, e poi condivido quanto ho già scritto (ma non sono sicuro che sia giusto).

• Ho 2 files: "Aggregato" (dal quale far partire le macro) e "Inviati"
• Il file "Aggregato" è composto da due fogli:
  • Confronto
  • Report
• Il file "Inviati" ha un unico foglio (Foglio 1)
• La macro presente sul file "Aggregato" dovrebbe effettuare le seguenti operazioni:
  • Cancellare tutto il contenuto del foglio "Confronto"
  • Cancellare il contenuto del foglio Report nelle sole colonne A-F, da riga 2 fino all'ultima riga compilata
  • Aprire un file .txt presente in una determinata cartella
  • Copiare il contenuto del file .txt nella colonna A del foglio "Confronto"
  • Chiudere il foglio .txt (chiudendo anche i due pop-up che si creano: la richiesta di salvare il file e di mantenere il contenuto degli appunti)
  • Aprire il foglio "Inviati"
  • Copiare il contenuto del foglio "Foglio 1" nelle sole colonne A-F, da riga 2 fino all'ultima riga compilata
  • Selezionare il file "Aggregato", foglio "Report" e incollare il contenuto appena copiato nelle colonne A-F, da riga 2 fino all'ultima riga necessaria
  • Confermare che è avvenuto tutto correttamente.

Per il momento ho scritto questo codice, ma credo che ci sia qualcosa che non va:

Sub Step_2()

' CANCELLA CONTENUTO PRECEDENTE

    Sheets("Confronto").Select 

    Cells.Select 

    Selection.ClearContents 

'

' IMPORTA FILE TXT

'

Workbooks.OpenText Filename:="C:\File.txt", Origin:= \_ 

    xlWindows, StartRow:=6, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, \_ 

    9), Array(10, 9), Array(21, 9), Array(36, 1)), TrailingMinusNumbers:=True 

ActiveCell.Columns("A:A").EntireColumn.Select 

Selection.Copy 

Windows("Aggregato.xlsm").Activate 

Sheets("Confronto").Select 

ActiveCell.Columns("A:A").EntireColumn.Select 

ActiveSheet.Paste 

Windows("File.txt").Activate 

ActiveWindow.Close 

'

' COPIA-INCOLLA DA FILE DI LEASYS

'

Workbooks.Open Filename:="C:\Inviati.xlsx" 

ActiveCell.Offset(1, 0).Range("A1").Select 

Range(Selection, Selection.End(xlToRight)).Select 

Range(Selection, Selection.End(xlDown)).Select 

Selection.Copy 

Windows("Aggregato.xlsm").Activate 

Sheets("Report").Select 

ActiveCell.Range("A1").Select 

ActiveSheet.Paste 

Windows("Inviati.xlsx").Activate 

ActiveWindow.Close 

End Sub

Answer 1

Ciao Francesco,

Solo un'ultima domanda e una curiosità.

• La domanda: quando parte la macro "Step_2", correttamente toglie la protezione al foglio e la rimette. Quando la rimette, però, non è più possibile usare i filtri sulla riga 1. C'è un modo per selezionare alcune opzioni quando si reinserisce la password (ecco uno screenshot)?

Sostituisci la procedura Step_2 con la seguente versione, in cui la modifica è evidenziata in verde

'========>>

Option Explicit

'-------->>

Public Sub Step_2()

Dim WB\_Inviati As Workbook, WB\_Testo As Workbook 

Dim SH\_Report As Worksheet, SH\_Confronto As Worksheet 

Dim SH\_Inviati As Worksheet 

Dim Rng\_Inviati As Range 

Dim sPath As String, sSeparatore As String 

Const sPercorso As String = **"C\CARTELLA\" '                    '<<=== Modifica** 

Const sFoglio\_Report As String = **"Report"** 

Const sFoglio\_Confronto As String = **"Confronto"** 

Const sFoglio\_Inviati As String = **"Foglio1"** 

Const sFile\_Inviati As String = **"Inviati"** 

Const sFile\_Testo As String = **"ElencoCartelle.txt"** 

Const sPassword As String = **"Password"                          '<<=== Modifica** 

sSeparatore = Application.PathSeparator 

If Right(sPercorso, 1) = sSeparatore Then 

    sPath = sPercorso 

Else 

    sPath = sPercorso & sSeparatore 

End If 

With ThisWorkbook 

    Set SH\_Report = .Sheets(sFoglio\_Report) 

    Set SH\_Confronto = .Sheets(sFoglio\_Confronto) 

End With 

On Error GoTo XIT 

Application.ScreenUpdating = False 

SH\_Confronto.UsedRange.ClearContents 

SH\_Report.Unprotect Password:=sPassword 

'\\ IMPORTA FILE TXT 

Workbooks.OpenText Filename:=sPath & sFile\_Testo, \_ 

    Origin:=xlWindows, StartRow:=6, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(10, 9), Array(21, 9), Array(36, 1)), TrailingMinusNumbers:=True 

Set WB\_Testo = ActiveWorkbook 

With WB\_Testo 

    .Sheets(1).Columns("A:A").Copy Destination:=SH\_Confronto.Range("A1") 

    .Close SaveChanges:=False 

End With 

'\\ COPIA-INCOLLA DA FILE DI LEASYS 

Set WB\_Inviati = Workbooks.Open(Filename:=sPath & sFile\_Inviati) 

Set SH\_Inviati = WB\_Inviati.Sheets(sFoglio\_Inviati) 

Set Rng\_Inviati = SH\_Inviati.Range("A1").CurrentRegion 

Rng\_Inviati.Copy Destination:=SH\_Report.Range("A1") 

WB\_Inviati.Close SaveChanges:=False 

Call MsgBox(Prompt:="Fatto", Buttons:=vbInformation, Title:="REPORT") 

XIT:

Application.ScreenUpdating = True 

SH\_Report.Protect Password:=sPassword**, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True** 

End Sub

'<<========

• La curiosità: vorrei aggiungere nell'oggetto dell'email (COLONNA J del file "Aggregato") la data (Colonna C del file "Aggregato"). Come posso fare? Ci ho provato più volte ma restituisce sempre il formato tipo 44599...

Nella procedura Step_3, sostituisci l'istruzione:

            .Subject = arrIn(i, 10)

con:

            .Subject = arrIn(i, 10) **& Space(1) & "Data: " & Format(arrIn(i, 3), "dd/mm/yyyy")** 

Nota bene:

Vista la prima richiesta di cui sopra, nella funzione LastRow del modulo di codice Modulo 1, sarà necessario sostituire l'istruzione

      SH.Protect Password:=sPassword, UserInterfaceOnly:=True

con:
SH.Protect Password:=sPassword, UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True

===

Regards,

Norman

Answer 2

Fatto. Purtroppo restituisce il seguente errore: "Errore di compilazione: Sub o Function non definita"...

Ho provato anche a togliere la protezione dal foglio, ma non sembra andare...

Answer 3

Ciao Francesco,

Sei un mitoooo! :-) Grazie davvero.

Prima o poi imparerò anche io i segreti di VBA :-)

Approfitto della tua competenza per chiederti una cosa.

Tra il lancio della macro "step_2" ed il lancio della macro "step_3", gli utenti cancellano le righe nelle quali la colonna G restituisce "NON PRESENTE". Secondo te, c'è un modo per cancellare quelle righe oppure (meglio ancora!) impostare la macro "step_3" affinchè salti le righe in cui in G c'è "NON PRESENTE"?

Per evitare che vengano create email se il valore della colonna CHECK restituisce NON PRESENTE, sostituisci la procedura Step_3 con la seguente versione:

'========>>

Option Explicit

'-------->>

Public Sub Step_3()

'\\ INVIO EMAIL 

Dim WB As Workbook 

Dim SH As Worksheet 

Dim Rng As Range 

Dim arrIn As Variant 

Dim oOutlook As Object 

Dim oMail As Object 

**Dim sNumero\_Sinistro As String** 

**Dim sTarga As String** 

**Dim sData\_Sinistro As String** 

**Dim sTipo\_Sinistro As String** 

**Dim sRagione\_Sociale As String** 

**Dim sImporto\_Danno As String** 

Dim sPercorso As String 

Dim sAllegato As String 

Dim sOggetto As String 

Dim LRow As Long, i As Long 

Const sFoglio As String = **"Report"                                      '<<=== Modifica** 

Const sSalutazione As String = **"Buongiorno."                    '<<=== Modifica** 

Set WB = ThisWorkbook 

Set SH = WB.Sheets(sFoglio) 

With SH 

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

    Set Rng = .Range("A2:J" & LRow) 

End With 

arrIn = Rng.Value2 

Set oOutlook = CreateObject("Outlook.Application") 

For i = 1 To UBound(arrIn) 

    If arrIn(i, 7) <> "NON PRESENTE" Then 

        Set oMail = oOutlook.CreateItem(0) 

        With oMail 

            'sIndirizzo = arrIn(1, 1) 

            'sCognome = arrIn(i, 2) 

            'sNome = arrIn(i, 3) 

            'sTitolo = arrIn(i, 4) 

            sPercorso = arrIn(i, 8) 

            sAllegato = arrIn(i, 9) 

            .To = "******@prova.com"                                  **'<<=== Modifica** 

            .CC = "******@prova.com"                                 **'<<=== Modifica** 

            .BCC = "******@prova.com"                               **'<<=== Modifica** 

            .Subject = arrIn(i, 10) 

            .Body = sSalutazione \_ 

                & vbNewLine & vbNewLine \_ 

                & "Alleghiamo il file " & sAllegato 

            .Attachments.Add sPercorso \_ 

                & Application.PathSeparator \_ 

                & sAllegato 

            .Send 

        End With 

        Set oMail = Nothing 

    End If 

Next i 

MsgBox "Email inviate correttamente!", vbInformation, "AVVISO" 

Set oMail = Nothing 

Set oOutlook = Nothing 

End Sub

'<<========

Nota che le variabili evidenziate in verde, che tu hai aggiunto al mio codice originale, non sono utilizzate nel codice e sembrano superflue.

===

Regards,

Norman

Answer 4

Sei un mitoooo! :-) Grazie davvero.

Prima o poi imparerò anche io i segreti di VBA :-)

Approfitto della tua competenza per chiederti una cosa.

Tra il lancio della macro "step_2" ed il lancio della macro "step_3", gli utenti cancellano le righe nelle quali la colonna G restituisce "NON PRESENTE". Secondo te, c'è un modo per cancellare quelle righe oppure (meglio ancora!) impostare la macro "step_3" affinchè salti le righe in cui in G c'è "NON PRESENTE"?

Answer 5

Ciao Francesco,

Grazie mille davvero per il tuo aiuto!

Ho sostituito la macro. Funziona tutto perfettamente ma a patto che tolga manualmente la password al foglio.

C'è un modo per far copia-incollare mantenendo la protezione del foglio?

Le righe di codice interessate sono le seguenti:

'\ COPIA-INCOLLA DA FILE INVIATI

Set WB_Inviati = Workbooks.Open(Filename:=sPath & sFile_INVIATI)

Set SH_Inviati = WB_Inviati.Sheets(sFoglio_Inviati)

Set Rng_Inviati = SH_Inviati.Range("A1").CurrentRegion

Rng_Inviati.Copy Destination:=SH_Report.Range("A1")

WB_Inviati.Close SaveChanges:=False

Call MsgBox(Prompt:="Fatto", Buttons:=vbInformation, Title:="REPORT")

Grazie ancora! :-)

Sostituisci il codice precedente con la seguente versione in cui le modifiche sono evidenziate in verde:

'========>>

Option Explicit

'-------->>

Public Sub Step_2()

Dim WB\_Inviati As Workbook, WB\_Testo As Workbook 

Dim SH\_Report As Worksheet, SH\_Confronto As Worksheet 

Dim SH\_Inviati As Worksheet 

Dim Rng\_Inviati As Range 

Dim sPath As String, sSeparatore As String 

Const sPercorso As String = **"C\CARTELLA\"                  '<<=== Modifica** 

Const sFoglio\_Report As String = **"Report"** 

Const sFoglio\_Confronto As String = **"Confronto"** 

Const sFoglio\_Inviati As String = **"Foglio1"** 

Const sFile\_Inviati As String = **"Inviati"** 

Const sFile\_Testo As String = **"ElencoCartelle.txt"** 

**Const sPassword As String = "Password"                        '<<=== Modifica** 

sSeparatore = Application.PathSeparator 

If Right(sPercorso, 1) = sSeparatore Then 

    sPath = sPercorso 

Else 

    sPath = sPercorso & sSeparatore 

End If 

With ThisWorkbook 

    Set SH\_Report = .Sheets(sFoglio\_Report) 

    Set SH\_Confronto = .Sheets(sFoglio\_Confronto) 

End With 

On Error GoTo XIT 

Application.ScreenUpdating = False 

SH\_Confronto.UsedRange.ClearContents 

**SH\_Report.Unprotect Password:=sPassword** 

'\\ IMPORTA FILE TXT 

Workbooks.OpenText Filename:=sPath & sFile\_Testo, \_ 

    Origin:=xlWindows, StartRow:=6, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(10, 9), Array(21, 9), Array(36, 1)), TrailingMinusNumbers:=True 

Set WB\_Testo = ActiveWorkbook 

With WB\_Testo 

    .Sheets(1).Columns("A:A").Copy Destination:=SH\_Confronto.Range("A1") 

    .Close SaveChanges:=False 

End With 

'\\ COPIA-INCOLLA DA FILE DI LEASYS 

Set WB\_Inviati = Workbooks.Open(Filename:=sPath & sFile\_Inviati) 

Set SH\_Inviati = WB\_Inviati.Sheets(sFoglio\_Inviati) 

Set Rng\_Inviati = SH\_Inviati.Range("A1").CurrentRegion 

Rng\_Inviati.Copy Destination:=SH\_Report.Range("A1") 

WB\_Inviati.Close SaveChanges:=False 

Call MsgBox(Prompt:="Fatto", Buttons:=vbInformation, Title:="REPORT") 

XIT:

Application.ScreenUpdating = True 

**SH\_Report.Protect Password:=sPassword** 

End Sub

'<<========

===

Regards,

Norman