Ciclo for per celle filtrate e creare allegato posta elettronica.

Question

Buongiorno a tutti. 

Nel foglio1, precisamente dalla cella F15 in giù, ho dei valori filtrati. 

Con il vostro aiuto, desidererei ottenere quanto segue:

1. scorrere con un ciclo le celle filtrate, dalla F15 fino all'ultima occupata. 
2. il ciclo, man mano che scorre le celle filtrate, deve incollare, nella cella F2 del Foglio2, ogni valore ciclato. 

3)infine, per ogni valore inserito nella cella F2 del Foglio2, occorre creare un allegato (cioè sempre di tutti i dati del Foglio2) in formato Excel e/o Pdf, da inviare via e. Mail. 

Per ora mi fermo qui con la speranza di aver spiegato bene la mia esigenza. 

Ringrazio chi mi aiuta in questo. 

Ciao, Nicola.

Answer 1

Buongiorno a tutti.

Volevo chiedere a voi esperti se c'è la possibilità di migliorare la velocità ( o del tutto)  queste routines che ho creato per quanto oggetto della mia domanda iniziale.

Public Sub SendWorkSheetToPDF()
'Update 20131209
Dim wb As Workbook
Dim xIndex
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Sheets("Foglio2").Select
Application.ScreenUpdating = False
Set wb = Application.ActiveWorkbook
FileName = wb.FullName
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & "_" + ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
    .to = ActiveSheet.Range("S2") & "@libero.it"
    .CC = ""
    .BCC = ""
    .Subject = "Comunicazioni ore tagliate nel mese indicato"
    .Body = "Gentile collega,xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" _
    & "wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww." _
    & vbCrLf & "Cordiali saluti."
    .Attachments.Add FileName
    .Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub

Sub SpecialLoop()
Dim LastRow As Long
Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
    End With
    Dim cl As Range, rng As Range
    Dim i As Long
    Set rng = Range("F15:F" & LastRow)
    For Each cl In rng.SpecialCells(xlCellTypeVisible)
      Sheets("Foglio2").Range("F2").Value = cl.Value     'Debug.Print cl
    
      'MsgBox cl
    Call SendWorkSheetToPDF
    Application.StatusBar = "Sto inviando la Mail al seguente Militare:" & Sheets("Foglio2").Range("D2") & " " & Sheets("Foglio2").Range("E2")
    Next cl
MsgBox "OK, Ho Tterminato. ", vbInformation
Application.ScreenUpdating = True
End Sub

Ciao, Nicola.

Answer 2

Buona sera a tutti.

Chiedo gentilmente se avete modo di riscontrare e di aiutarmi nella mia esigenza.

Io ho compiuto un passo avanti, ho creato questa routine che mi permette di allegare il Foglio2 cone allegato di posta elettronica.

Quello che non riesco a fare è creare un ciclo che scorra il range sopraccennato ed incolli i relativi valori nella cella F2 del Foglio2.

Sub Allegato_Foglio2()

Dim xFile As String

Dim xFormat As Long

Dim Wb As Workbook

Dim Wb2 As Workbook

Dim FilePath As String

Dim FileName As String

Dim OutlookApp As Object

Dim OutlookMail As Object

On Error Resume Next

Sheets("Foglio2").Select

Application.ScreenUpdating = False

Set Wb = Application.ActiveWorkbook

ActiveSheet.Copy

Set Wb2 = Application.ActiveWorkbook

Select Case Wb.FileFormat

Case xlOpenXMLWorkbook:

xFile = ".xlsx"

xFormat = xlOpenXMLWorkbook

Case xlOpenXMLWorkbookMacroEnabled:

If Wb2.HasVBProject Then

    xFile = ".xlsm"

    xFormat = xlOpenXMLWorkbookMacroEnabled

Else

    xFile = ".xlsx"

    xFormat = xlOpenXMLWorkbook

End If

Case Excel8:

xFile = ".xls"

xFormat = Excel8

Case xlExcel12:

xFile = ".xlsb"

xFormat = xlExcel12

End Select

FilePath = Environ$("temp") & ""

FileName = Wb.Name & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutlookApp = CreateObject("Outlook.Application")

Set OutlookMail = OutlookApp.CreateItem(0)

Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat

With OutlookMail

.To = "******@libero.it"

.CC = ""

.BCC = ""

.Subject = "Invio allegato"

.Body = "Non Rispondere a questa mail."

.Attachments.Add Wb2.FullName

.Send

End With

Wb2.Close

Kill FilePath & FileName & xFile

Set OutlookMail = Nothing

Set OutlookApp = Nothing

Application.ScreenUpdating = True

End Sub

Attendo fiducioso un vostro cortese e prezioso aiuto.

Ciao, Nicola.

Answer 3

Allego al seguente link il file che sul quale creare le routine di cui necessito per ottenre quanto inizialmenete richiesto.

https://1drv.ms/x/s!Ali6qqOH3dOAk3W9lqotds4D\_BiI?e=WSz0w7

P.S. il ciclo deve scorrere il range dei dati evidenziati di giallo nel Foglio1 in colonna F e ogni valore di quel range deve essere incollato nella cella F2 del Foglio2.

Questi dati, nella realtà sono tutti nomi ai quali poi inviare un messaggio di posta elettronica con il Foglio2 allegato( In formato Excel e/o PDF, è indifferente).

Spero di essere stato chiaro.

Ciao, Nicola

Answer 4

Buona sera.

Ho iniziato il mio progetto creando inizialmente la routine che nasconde le righe che non hanno dati nelle celle indicate:

Private Sub Nascondi_righe()

Dim Rng As Range, rCell As Range

Const sCelle As String = "Q15:AC77"                         '<<=== Modifica

Set Rng = Me.Range(sCelle)

On Error GoTo 0

Application.EnableEvents = False

For Each rCell In Rng.Cells

    With rCell

        .EntireRow.Hidden = .Value = ""

    End With

Next rCell

XIT:

Application.EnableEvents = True

End Sub

Ma ho notato che è molto lenta, non si potrebbe velocizzare per favore?

poi successivamente ho creato questa ulteriore routine per scorrere le celle indicate ma qualcosa non va, mi incolla nel Foglio2, nella cella F2 solo l'ultimo valore del range e cioè il valore della cella F60.

Private Sub Scorri_Matricole()

Dim Cell As Range

For Each Cell In Sheets("Foglio1").Range("F15:F60")

If Len(Cell.Value) = 7 Or Cell.Value <> "" Then

  Sheets("Foglio2").Range("F2") = Cell.Value

'ElseIf Cell.Value < 0 Then

  'Cell.Offset(0, 1).Value = "Negative"

'Else

  'Cell.Offset(0, 1).Value = "Zero"

 End If

Next Cell

End Sub

Mi aiutate, per ora a migliorare queste 2 routine?

Grazie a chi mi aiuta.

Ciao, Nicola