Úgy látszik, hogy ez most már csak egy ilyen hét lesz, ugyanis a mai téma sem más, mint VBA és ezúttal is egy olvasói kérdést fogunk körbejárni, de a korábbi posztokban átnézett levélküldési megoldások ismeretében ezzel már relatíve gyorsan fogok végezni.

Szóval kedves Olvasóm a következőt szeretné elérni: van egy hatalmas Excel-fájlja rengeteg adattal és ebben rendszeresen szokott szűrni (mondjuk azt, hogy például vevőnév alapján), majd a leszűrt állományt egy másik Excelbe rakja át, amit aztán levélben továbbküld. A cél ennek elérése úgy, hogy a szűrésen kívül semmilyen egyéb feladata ne legyen már.

A kérdés pont kapóra jött, hiszen mostanában ilyen témákat jártam körül, tehát maga a levélküldés önmagában nem okozhat már gondot, amiről még nem beszéltünk az az új workbookok létrehozása, törlése és szűrt állományok másolása.

Első lépésként létrehoztam egy gombot az adatállományunk sheetjén és ehhez rendelem majd hozzá a kódot:

A kódot értelemszerűen a változók deklarálásával kezdjük, mivel e-mailt küldeni fogunk, ezért a megszokott módon, objektum típussal deklarálunk egy outlook és egy mail nevű változót, hiszen így majd ezen osztályok bármely tulajdonságához, metódusához hozzáférhetünk később.

Egy lendülettel állítsuk is be a két változó kezdő értékét, az outlook maga az Outlook applikáció elindítása, a mail pedig egy új e-mail létrehozására vonatkozó utasítás, amelyet az outlook változó utasításaként hívunk meg.

Workbooks.Add utasítás segítségével tudunk létrehozni egy új Excel-munkafüzetet, amit aztán le is mentünk a megfelelő helyre. Mivel akkor már az új munkafüzetünk az aktív munkafüzet, így bátran használhatjuk az ActiveWorkbook.SaveAs utasítást:

Workbooks.Add
ActiveWorkbook.SaveAs "C:\...az uj fajl neve"

Ezután jön rövid kódunk kulcsmomentuma, hiszen egyrészt a Workbooks("...xls").Activate utasítással ismét az adatállományt tartalmazó munkafüzetünket tesszük aktívvá, majd ennek első munkalapján kezdünk dolgozni.

Szóval ismét csak írjuk le gondolatban, mit is akarunk tenni: az első munkalapunk (Worksheets("Sheet1")) összes adatot tartalmazó cellájának (ez a Worksheet.UsedRange tulajdonság) azon speciális halmazára van szükségünk (itt a Range.SpecialCells metódust vetjük be, amelynek paraméterei között van az a paraméter, ami most kell nekünk), amelyek éppen láthatóak a táblában (ez a Range.SpecialCell metódus xlCellTypeVisible tulajdonsága - a részletes tulajdonságlista a Microsoft leírásában megtalálható), majd ezt rakjuk be a vágólapra (.Copy). A .Copy metódusnak egyetlen paramétere van, ez a beillesztési paraméter (Destination), amely után := megadásával tudunk felvinni célt, jelen esetben az új fájlunk (Workbooks("az uj fajl.xls")) első munkalapjának (Sheets("Sheet1")) A1 cellájába illessze be állományunkat (.Range("A1")).

Workbooks("Ahol az adathalmaz van.xls").Activate
Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Workbooks("az uj fajlom").Sheets("Sheet1").Range("A1")

Ezután pedig mondhatni megszokott részek következnek, hiszen With...End With felhasználásával az újonnan létrehozott levelünket készítjük elő (ehhez deklaráltuk és állítottuk be a mail változót), méghozzá mondjuk egy címzett (.To), egy tárgy (.Subject), egy szöveg (.Body) megadásával, majd az eddig még nem használt .Attachments.Add ("C:\...az uj fajl.xls") metódussal becsatoljuk a leszűrt állományt tartalmazó fájlunkat és küldés előtt még átnézzük (.Display).

With mail
.To = "officeguruhelp@gmail.com"
.Subject = "OfficeGuru"
.Body = "Csatolva küldöm a részleteket!"
.Attachments.Add ("C:\...az uj fajl neve.xls")
.Display
End With

Ezután még töröljük ki fájlunkat egy Kill (C:\...az uj fajl neve.xls") utasítással, ürítsük ki a változóinkat és kész is vagyunk, a gombra kattintva elérjük a célt, amit olvasóm is szeretett volna.

Íme a kód szövegként is:

Private Sub CommandButton1_Click()
Dim outlook As Object
Dim mail As Object
Set outlook = CreateObject("Outlook.Application")
Set mail = outlook.CreateItem(0)
Workbooks.Add
ActiveWorkbook.SaveAs "C:\...az uj fajl neve"
Workbooks("Ahol az adathalmaz van.xls").Activate
Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Workbooks("az uj fajlom").Sheets("Sheet1").Range("A1")
With mail
.To = "officeguruhelp@gmail.com"
.Subject = "OfficeGuru"
.Body = "Csatolva küldöm a részleteket!"
.Attachments.Add ("C:\...az uj fajl neve.xls")
.Display
End With
Set mail = Nothing
Set outlook = Nothing
End Sub
End Sub