ciao
benvenuto nel forum
adattando correttamente questa macro al tuo file potrebbe essere ok.
in C:\ devi avere una cartella di nome temp
in BB19 il primo nome della persona a cui spedire
in BC19 la realativa mail a cui spedire
devi usare microsoft ouotlook,
nel quale devi avere gia un account abilitato/ gia configurato a spedirte posta.
poi leggi la macro
adatta i nomi dei file e del contenuto , oggetto eccc...
ciao
- Codice: Seleziona tutto
Sub fibonc2num()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String
Dim BodyText As String
scelta = MsgBox(Prompt:=" Stai per Spedire SOLO questo foglio ", Buttons:=vbYesNo, _
Title:=" Mando E.mail ai soci ? ")
If scelta = 6 Then '6 = SI; 7=No
ActiveSheet.Unprotect
userform1.Show vbModeless
DoEvents
INIZIO = Timer
Range("BB19:BC29").Select ' <<< ordino gli indirizzi e le do'il formato carattere "colibri"
Selection.Sort Key1:=Range("BB19"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BC19:BC29").Select
With Selection.Font
.Name = "Calibri"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.Underline = xlUnderlineStyleNone
Selection.Font.ColorIndex = 1
Range("A13").Select
'(a)
UR = Range("BC" & Rows.Count).End(xlUp).Row '<<< prende gli indirizzi inCol BC
'(b)
Application.EnableEvents = False '<<<<<<<< per non far partire il lampeggio in fgl1
Sheets("fibonacci_2num").Copy '<<< il foglio da spedire
ChDir "C:\Temp" '<<< dove appoggia il file con 1 solo foglio
ActiveWorkbook.SaveAs Filename:="C:\Temp\email-fibon2n.xls" ' <<< e' il file tempor con 1 solo fogl da spedire
Range("Bb19:BC" & UR).ClearContents '<<<< riga che cancella l'elenco delle email solo sul foglio che invii
ActiveWindow.Close SaveChanges:=True
Indir = ""
For RR = 19 To UR
Indir = Indir & Range("BC" & RR).Value & "; "
Next RR
destinat = "" & Indir & ""
BDT = "Ti invio il foglio con i 2 numeri in gioco" & vbCrLf '<<< da qui si compila il contenuto dell'email
BDT = BDT & vbCrLf & "per aprire il foglio premi --> DISATTIVA macro"
BDT = BDT & vbCrLf & "Perche' essendo questo, solo un foglio del file originale, le macro non funzioneranno." & vbCrLf
BDT = BDT & vbCrLf & "collegati qui per vedere i numeri estratti alle h 14,30 & h 18,30" & vbCrLf
BDT = BDT & vbCrLf & " http://www.bet365-italiano.com/home/FlashGen4/WebConsoleApp.asp?lng=6" & vbCrLf
BDT = BDT & vbCrLf & "Buona Fortuna & Forsa Milan" & vbCrLf
BDT = BDT & vbCrLf & "Luga.lotto 49k" & vbCrLf
BDT = BDT & vbCrLf & "www.lelugarine.eu" & vbCrLf
BDT = BDT & vbCrLf & "" & vbCrLf
BDT = BDT & Format(Now(), "dd mmmm yyyy Ore HH:mm") & vbCrLf ' <<< data ed ora di spedizione
'(c)
Set OutApp = CreateObject("Outlook.Application")
OutFile = "C:\Temp\email-fibon2n.xls" ' e' il file temporaneo che allega
EmailAddr = Range("BC" & RR).Value
Subj = "Invio progressione fibonacci 2 numeri" '<<< l' oggetto del messaggio
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = destinat
.Subject = Subj
.Attachments.Add OutFile
.Body = BDT
.Display 'or use .send
End With
'(d)
Set OutMail = Nothing
'(e)
Set OutApp = Nothing
Application.Wait (Now + TimeValue("0:00:19")) '<<< tempo che l'email rimane aperta sul video prima dell'invio
Application.SendKeys "%a" ' <<< serve a premere -invia- sull'email che ha creato in outlook
Application.Wait (Now + TimeValue("0:00:13")) 'serve per lasciar partire l'email prima del messag. di fine macro
ActiveWindow.ScrollColumn = 1 ' porta le barre tutto a sx
ActiveWindow.ScrollRow = 1 ' alza la barra later dx
Application.EnableEvents = True 'riattiva le macro
Unload userform1
Fine = Timer
MsgBox ("Tempo impiegato " & Int((Fine - INIZIO) / 60) & " min " & (Fine - INIZIO) Mod 60 & " Sec")
Kill "C:\Temp\email-fibon2n.xls" '<<< serve a cancellare il file che crea in C: temp
End If
Range("A13").Select
End Sub
S.O. win10, Excell 2019