(excel) slanje dokumenata e-mailom (Outlook 2010)

[ Sudarica @ 13.05.2011. 20:02 ] @

molim vas pomoć

pokušala sam sama ali nisam uspjela napisati makro naredbu za slanje dokumenata e-mailom iz fajla u excelu na određeni datum (npr.14.5.2011.)

Napravila sam radnu knjigu u kojoj se u koloni "A" nalazi naziv radne knjige koju želim poslati (npr Book1.xlsx, a u koloni "B" se nalazi e-mail adresa na koju šaljem tu radnu knjigu (npr.marko.marković@dora.hr) subjekt je isti za sve (npr. čokolada). Svi dokumenti za slanje nalaze se na adresi "C:\Maja\ .xls

(sada šaljem svaki e-mail pojedinačno (ima ih oko 200) koristim adresu marko.marković@dora.hr?subject=čokolada na kojoj je link i odmah mi je upisivan subjekt) ali je ovo strašno naporno i ubija stoga vas molim pomoć

Srdačan pozdrav

[ neptuncokg @ 13.05.2011. 23:54 ] @

" ali je ovo strašno naporno i ubija stoga vas molim pomoć "...
A što ne pošaljes primer, toga sto je strašno ? Ova tema je jako interesantna, svako ima svoje "prohteve" kad je reč o slanju e-maila iz excela.
Pozdrav

[ Jpeca @ 14.05.2011. 08:23 ] @

Pogledaj http://www.elitesecurity.org/t414835-0#2740260

[ Sudarica @ 14.05.2011. 08:54 ] @

Dosadno je jer se ponavlja
Ovako to radim klik na adresu otvara se e-mail uvučem dokument pišem tekst primatelju
"U prilogu vam šaljem specifikaciju.
pozdrav,"

i tako 200 puta.

možda još pojašnjenje u fajlu "C:\Maja\ se nalaze dokumenti (oko 200 jedan od njih je i Book1.xlsx) koje moram poslati na adrese koje se nalaze u "C:\Adrese\E-mail adrese.xlsx.

Osim toga trebala bi biti i nekakva kontrola koja će mi na kraju reći da su poslani svi dokumenti ili ako nisu koji su to (razlog zašto nisu poslani može biti da dokumenat nema adresu)

nadam se da sam dobro objasnila

[ Sudarica @ 14.05.2011. 10:24 ] @

Citat:

Jpeca: Pogledaj http://www.elitesecurity.org/t414835-0#2740260

hvala, već sam pokušala prilagoditi jer ovo je direktno slanje iz dokumenta, a ja trebam pripremljeni dokumenat kojeg sam pripremila prije, poslati u određeno vrijeme, recimo u ponedjeljak, svih 200 dokumenata poslati svaki na određenu adresu kao što je u prilogu

[ Ivek33 @ 14.05.2011. 19:41 ] @

Citat:

Sudarica: ja trebam pripremljeni dokumenat kojeg sam pripremila prije, poslati u određeno vrijeme

Koliko sam shvatio ti imaš 200 *.XLS files
Želiš određene files kao attach poslati na određenu e-mail adresu, i to u jednom koraku

Nekada davno sam gledao takvu mogućnost ali iz Outlooka pa sam se sjetio VBA makronaredbe koju je napisao rondebruin
Ovaj Macro koristi se u Workbook
U Sheet1 upišeš sve podatke koji su potrebni
Ime-e-mail-path to filee

Pokretanjem Macroa automatski ti se u Outlooku kreiraju e-mail poruke sa prikačenim attachmentima
(postoji problem, ako trebaš dodati više teksta kao poruku ali i to se da riješiti dodatnim izmjenama)

Međutim ne znam kako će reagirati tvoj ISP e-mail provider ako u jednom koraku pođeš slati 200 poruka.
Probao sam jednom poslati Mailmerge više e-mail poruka preko Outlooka (150 poruka) i bilo je problema pa sam morao 20 po 20 poruka slati jer je navodno moj ISP to smatrao spamom. No nisam siguran probaj.

Evo Macro koji ćeš vjerojatno morati doraditi ako ti odgovara (vidi file u prilogu ove poruke)

Code:
Sub Send_Files()
'Working in 2000-2010
 Dim OutApp As Object
 Dim OutMail As Object
 Dim sh As Worksheet
 Dim cell As Range, FileCell As Range, rng As Range

 With Application
 .EnableEvents = False
 .ScreenUpdating = False
 End With

 Set sh = Sheets("Sheet1")

 Set OutApp = CreateObject("Outlook.Application")

 For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

 'Enter the file names in the C:Z column in each row
 Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

 If cell.Value Like "?*@?*.?*" And _
 Application.WorksheetFunction.CountA(rng) > 0 Then
 Set OutMail = OutApp.CreateItem(0)

 With OutMail
 .to = cell.Value
 .Subject = "Izvješće za Svibanj 2011"
 .Body = "Pozdrav " & cell.Offset(0, -1).Value

 For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
 If Trim(FileCell) <> "" Then
 If Dir(FileCell.Value) <> "" Then
 .Attachments.Add FileCell.Value
 End If
 End If
 Next FileCell

 .Send 'Or use .Display
 End With

 Set OutMail = Nothing
 End If
 Next cell

 Set OutApp = Nothing
 With Application
 .EnableEvents = True
 .ScreenUpdating = True
 End With
End Sub

[ Sudarica @ 14.05.2011. 21:06 ] @

Ne mogu sada isprobati, nešto sam si poremetila u Outlooku, moram pronaći što. Jedva čekam da to isprobam.

hvala ti

srdačan pozdrav

[ Sudarica @ 15.05.2011. 09:40 ] @

Ivek radi probala sam na dva primatelja super.

Dali postoji mogućnost da se prepišu svi naslovi dokumenata koji su pripremljeni za slanje u fajlu c:\Temp , Onda bi tom popisu pomoću funkcije CONCATENATE pripojila put, a pretraživačem iz dokumenta E-mail adrese.xlsx. upisala adresu i na taj način popunila potrebne stupce SendMultipleWorkbooks.xls i bila sigurna da mi je sve točno prije nego kliknem na pošalji.

Od tog popisa ću onda lako moći napraviti više SendMultipleWorkbooks.xls ako bude problema kod slanja.

[ Ivek33 @ 15.05.2011. 12:03 ] @

Citat:

Sudarica: Dali postoji mogućnost da se prepišu svi naslovi dokumenata koji su pripremljeni za slanje u fajlu c:\Temp

Google čuda čini

Ovaj Macro služi za pronalaženje naziva svih files u folderu C:\Temp
Pokretanjem macroa kreira se novi Sheet i u njemu popis

Code:
Sub ListAllFile()
'radi u Excel 2007
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add

    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder("C:\Temp\")
    ws.Cells(1, 1).Value = "Files pronađeni u " & objFolder.Name & " su:"

    'Loop through the Files collection
    For Each objFile In objFolder.Files
        ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
    Next

    'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

End Sub

btw: proguglaj ima još makronaredbi koje rade isti ili sličan posao.

[ Sudarica @ 15.05.2011. 16:06 ] @

Ivek ti si sunčeko hvala ti idem testirati

Hvala

[ Sudarica @ 15.05.2011. 16:51 ] @

Prvi test

prepisala sam datoteke (prepisane su u kolonu A) sada sam u kolonu B dodala put (C:\temp) pomoću CONCATENATE=C:\temp;"\";book1 tako sam dobila FileNama1. Sada ću pomoću Vlookup pronaći odgovarajuće adrese. Sve pretvoriti u vrijednosti ( paste Value) uljepiti u colonu adrese i dodati linkove i to je pretpostavljam to. Javiću se

[ Ivek33 @ 15.05.2011. 18:22 ] @

Citat:

Sudarica: prepisala sam datoteke (prepisane su u kolonu A) sada sam u kolonu B dodala put (C:\temp) pomoću CONCATENATE=C:\temp;"\";book1 tako sam dobila FileNama1.

Ajde dobro ako te to zadovoljava

Pitam se zašto hoćeš dobiti samo imena svih files pa kombinirati sa funkcijom Concatenate kada možeš odmah dobiti cijelu path stazu za sve files u folderu.

Ovaj macro ispod upravo to radi (vidi attach poruke)
(ako ga kopiraš trebaš u dotičnoj Workbook u VBE aktivirati Tools => References => i uključiti Microsoft Scripting Runtime

Code:
Dim iRow

Sub ListPathNameFiles()
    iRow = 5
    Call ListMyFiles(Range("B1"), Range("B2"))
End Sub

Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    On Error Resume Next
    For Each myFile In mySource.Files
        iCol = 1
        Cells(iRow, iCol).Value = myFile.Path
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.Name
        iRow = iRow + 1
    Next
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            Call ListMyFiles(mySubFolder.Path, True)
        Next
    End If
End Sub

[ Sudarica @ 16.05.2011. 16:59 ] @

Odlično radi super svaka čast

imam još jedan problem a vidjela sam malo po forumima da je to problem inače.

Kada šalješ e_mail iz Excela nemaš Digital Signature (potpis), znam da ćeš reći da Ron de Bruin ima rješenje ali meni smeta GetBoiler (malo mi fali engleski)

[ Ivek33 @ 18.05.2011. 10:52 ] @

Citat:

Sudarica: imam još jedan problem a vidjela sam malo po forumima da je to problem inače.

Kada šalješ e_mail iz Excela nemaš Digital Signature (potpis), znam da ćeš reći da Ron de Bruin ima rješenje ali meni smeta GetBoiler (malo mi fali engleski)

I nije to problem kada šalješ jedan snimljeni-ažurirani Workbook iz Excela putem e-maila, ali ne znam kako bi to bilo na tvom primjeru i tvojim zahtjevima (možda bi mogao netko tko aktivno programira u VBA?)

Kao što si rekla Ron de Bruin ima rješenje za to (slanje Workbook na više e-mail adresa uz prikačeni Signature).
Što se tiče GetBoiler jednostavno ga kopiraj u neki module tvoje radne knjige

Code:
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Drugi Macro zavisi šalješ li HTML ili PLAIN predložak. Ovo je primjer za Html predložak

Code:
Sub Mail_Outlook_With_Signature_Html()
' Ne zaboravi kopirati funkciju GetBoiler u module.
' radi u Office 2000-2010
 Dim OutApp As Object
 Dim OutMail As Object
 Dim strbody As String
 Dim SigString As String
 Dim Signature As String

 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)

 strbody = "<H2>Poštovani prijatelju</H2>" & _
 "Šaljem ti izvešće za 2011 " & _
 "Javi mi ako ima problema " & _
 "<A HREF=""http://www.ic.ims.hr/index.html"">posjeti moju web stranicu</A>" & _
 " pozdravljam te i ugodno popodne"

 'Upotrijebi drugi SigString ako koristiš Vista ili Win 7 a prvi ignoriraj komentarima
 'ovo je prvi SigString
 SigString = "C:\Documents and Settings\" & Environ("username") & _
 "\Application Data\Microsoft\Signatures\TVOJ-SIGNATURE.htm"
 'ovo je drugi SigString
 'SigString = "C:\Users\" & Environ("username") & _
 "\AppData\Roaming\Microsoft\Signatures\TVOJ-SIGNATURE.htm"

 If Dir(SigString) <> "" Then
 Signature = GetBoiler(SigString)
 Else
 Signature = ""
 End If

 On Error Resume Next
 With OutMail
 .To = "[email protected]"
 .CC = "[email protected]"
 .BCC = ""
 .Subject = "Šaljem izvješće za 2011"
 .HTMLBody = strbody & " " & Signature
 'Možeš dodati attachment ako želiš
 '.Attachments.Add ("C:\test.txt")
 .Send 'Send je za automatsko slanje a .Display za pripremu slanja i mogućnost editiranja
 End With

 On Error GoTo 0
 Set OutMail = Nothing
 Set OutApp = Nothing
End Sub

Potrebno je da pronađeš naziv svog Signature na određenoj putanji i zamjeniš naziv "TVOJ-SIGNATURE.htm"
Ovo uredno funkcionira kada šaljem jedan Workbook na više e-mail adresa koje definiram u samoj makronaredbi.
Ne znam kako bi to ukomponirala u svoj problem, no možda bi se i moglo ?
btw: vidi attach i usput posjeti http://www.rondebruin.nl/mail/folder3/signature.htm

[ Sudarica @ 18.05.2011. 21:39 ] @

Hvala Ivek

sutra ću dodati u svoju naredbu

hvala ti puno

srdačan pozdrav

[ ramzesIV @ 20.05.2011. 08:47 ] @

pozdrav!

ovi makroi su stvarno super, ja imam jedno slicno pitanje:

postoji li mogucnost da se posalje iz outlook-a uz pomoc makroa reply na jedan mail uz attachment jednog excel fajla.

dobijem mail, ja u excelu uradim to sto treba i onda odgovorim na taj mail sa tim excelom kao attach?

ako ne onda da iz excela nekako posaljem aktivni excel sheet kao attach toj osobi?

[ Ivek33 @ 20.05.2011. 14:04 ] @

Citat:

ramzesIV: ako ne onda da iz excela nekako posaljem aktivni excel sheet kao attach toj osobi?

Da bi poslao aktivni Sheet iz Excela na e-mail iskoristi ovu makronaredbu, koju kopiraj u Module u VBE

- Otvori Outlook
- Pokreni Excel, ažuriraj Sheet i snimi Workbook pod nazivom koji je adekvatan elementima Sheeta koji želiš poslati
- Pozicioniran si na Sheetu koji želiš poslati, pokreni Macro (ALT+F8)
- Otvara ti se nova poruka u Outlooku
- Upiši e-mail adresu (koju moraš znati) i editiraj body text
- Pošalji

btw: editiraj dijelove da bi dobio ispravan Subject i naziv file koji šalješ

Code:
Option Explicit

Sub Mail_ActiveSheet()
'Working in 97-2010
 Dim FileExtStr As String
 Dim FileFormatNum As Long
 Dim Sourcewb As Workbook
 Dim Destwb As Workbook
 Dim TempFilePath As String
 Dim TempFileName As String
 Dim I As Long

 With Application
 .ScreenUpdating = False
 .EnableEvents = False
 End With

 Set Sourcewb = ActiveWorkbook

 'Copy the sheet to a new workbook
 ActiveSheet.Copy
 Set Destwb = ActiveWorkbook

 'Determine the Excel version and file extension/format
 With Destwb
 If Val(Application.Version) < 12 Then
 'You use Excel 97-2003
 FileExtStr = ".xls": FileFormatNum = -4143
 Else
 'You use Excel 2007-2010
 'We exit the sub when your answer is NO in the security dialog that you only
 'see when you copy a sheet from a xlsm file with macro's disabled.
 If Sourcewb.Name = .Name Then
 With Application
 .ScreenUpdating = True
 .EnableEvents = True
 End With
 MsgBox "Your answer is NO in the security dialog"
 Exit Sub
 Else
 Select Case Sourcewb.FileFormat
 Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
 Case 52:
 If .HasVBProject Then
 FileExtStr = ".xlsm": FileFormatNum = 52
 Else
 FileExtStr = ".xlsx": FileFormatNum = 51
 End If
 Case 56: FileExtStr = ".xls": FileFormatNum = 56
 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
 End Select
 End If
 End If
 End With

 ' 'Change all cells in the worksheet to values if you want
 ' With Destwb.Sheets(1).UsedRange
 ' .Cells.Copy
 ' .Cells.PasteSpecial xlPasteValues
 ' .Cells(1).Select
 ' End With
 ' Application.CutCopyMode = False

 'Save the new workbook/Mail it/Delete it
 TempFilePath = Environ$("temp") & "\"
 TempFileName = "Šaljem izvješće za " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

 With Destwb
 .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
 On Error Resume Next
 For I = 1 To 3
 .SendMail "", _
 "Ovo je izvješće za 2011"
 If Err.Number = 0 Then Exit For
 Next I
 On Error GoTo 0
 .Close SaveChanges:=False
 End With

 'Delete the file you have send
 Kill TempFilePath & TempFileName & FileExtStr

 With Application
 .ScreenUpdating = True
 .EnableEvents = True
 End With
End Sub

[ ramzesIV @ 20.05.2011. 14:29 ] @

Ivek, fenomenalno,

jos 3 pitanja:

1. da li mogu da saljem kopiju tog excela,
2. posto taj excel saljem samo na 4 razlicite osobe. ili jednoj ili drugoj ili 3 ili cetvrtoj, da li moze uz ovaj makro da se stavi i automatski upis maila. npr kad kliknem na E30 da salje jednoj, E31 drugoj, ...
3. posto mi je aktivan drugi excel. treba da napisem makro koji ce aktivirati excel koji saljem, pa onda da ga stavi kao attach, kopiju, pa da automatski unese mail?

ja sve imam snimljeno u excelu koji je snimljen kao Sim. i tu sam snimila tvoj makro.

a saljem excel "simulacija" kao attach. ono sto ja hocu je kliknem u excelu Sim makro i on salje simulaciju na mail.

ali i ovaj makro je super.

[ Ivek33 @ 20.05.2011. 20:30 ] @

Citat:

ramzesIV: 1. da li mogu da saljem kopiju tog excela,

Da bi poslala aktivni Sheet na određenu e-mail adresu koju želiš imati u nekoj ćeliji iskoristi ovaj Macro ispod (ako je ćelija A1 zauzeta koristi drugu ćeliju)

Šalje aktivni Sheet (kao attach) na e-mail adresu upisanu u ćeliji A1 dotičnog Sheeta. Znači možeš imati više Sheets ali u A1 različite e-mail adrese. Kada se pozicioniraš na određeni sheeet i pokreneš Macro on će poslati na e-mail adresu iz A1 na trenutnom sheetu sa kojega si pokrenula macro.

Code:

Option Explicit

Sub MailAddressActiveSheet()
'Working in 2000-2010
 Dim FileExtStr As String
 Dim FileFormatNum As Long
 Dim Sourcewb As Workbook
 Dim Destwb As Workbook
 Dim TempFilePath As String
 Dim TempFileName As String
 Dim OutApp As Object
 Dim OutMail As Object
 Dim ws As Worksheet

 With Application
 .ScreenUpdating = False
 .EnableEvents = False
 End With

 Set Sourcewb = ActiveWorkbook

 'kopira sheet u novu workbook
 ActiveSheet.Copy
 Set Destwb = ActiveWorkbook

 'Determine the Excel version and file extension/format
 With Destwb
 If Val(Application.Version) < 12 Then
 'You use Excel 97-2003
 FileExtStr = ".xls": FileFormatNum = -4143
 Else
 'You use Excel 2007-2010
 'We exit the sub when your answer is NO in the security dialog that you only
 'see when you copy a sheet from a xlsm file with macro's disabled.
 If Sourcewb.Name = .Name Then
 With Application
 .ScreenUpdating = True
 .EnableEvents = True
 End With
 MsgBox "Your answer is NO in the security dialog"
 Exit Sub
 Else
 Select Case Sourcewb.FileFormat
 Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
 Case 52:
 If .HasVBProject Then
 FileExtStr = ".xlsm": FileFormatNum = 52
 Else
 FileExtStr = ".xlsx": FileFormatNum = 51
 End If
 Case 56: FileExtStr = ".xls": FileFormatNum = 56
 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
 End Select
 End If
 End If
 End With

 ' 'Change all cells in the worksheet to values if you want
 ' With Destwb.Sheets(1).UsedRange
 ' .Cells.Copy
 ' .Cells.PasteSpecial xlPasteValues
 ' .Cells(1).Select
 ' End With
 ' Application.CutCopyMode = False

 'Save the new workbook/Mail it/Delete it
 TempFilePath = Environ$("temp") & "\"
 TempFileName = "Izjvjesce2011 " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

For Each ws In ActiveWorkbook.Worksheets
 If ws.Range("A1").Value Like "?*@?*.?*" Then
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)

 With Destwb
 .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
 On Error Resume Next
 With OutMail
 .to = ws.Range("A1").Value
 '.CC = ""
 '.BCC = ""
 .Subject = "Izvješće za 2011"
 .Body = "Pozdrav, šaljem vam izvješće za mjesec svibanj 2011"
 .Attachments.Add Destwb.FullName
 'You can add other files also like this
 '.Attachments.Add ("C:\test.txt")
 .Send 'ili upotrijebi .Display ako zelis dodatno editirati email poruku
 End With
 On Error GoTo 0
 .Close savechanges:=False
 End With

 'Delete the file you have send
 Kill TempFilePath & TempFileName & FileExtStr

 Set OutMail = Nothing
 Set OutApp = Nothing

 With Application
 .ScreenUpdating = True
 .EnableEvents = True
 End With
End If
 Next ws

End Sub

Ovaj macro automatski šalje aktivni Sheet (smješta ga u Outbox - MS Outlooka). Ako želiš dodatno imati mogućnost editiranja body teksta poruke tada umjesto .Send koristi naredbu .Display.
Za više detalja i mogućnosti pogledaj kako možeš poslati aktivni radni list na više e-mail adresa koje definiraš u samoj makronaredbi

[ neptuncokg @ 21.05.2011. 12:46 ] @

Posto je i meni ova tema jako interesantna, evo mog skromnog doprinosa. Dokumenat koji prilazem sluzi za:
1 - Slanje jednog, ili vise sheetova na izbranu adresu. Izbor sheetova se vrsi "dvoklikom" na padajucoj listi na formi, a slanje - klikom na button "POSALJI SHEET"
2 - Slanje celog dokumenta na izbranu adresu - klikom na button "POSALJI BOOK"
3 - Direktnu prepisku ("catovanje") - izborom sheeta "TEXT"

Ja sam to pravio za svoje potrebe, i kod mene lepo radi - pod Outlook Express-om. Medjutim, nisam uspeo da doradim program tako da pored izbora jednog, ili vise, sheetova za slanje, sve to saljem i na - vise adresa. Pozdrav

[ ramzesIV @ 21.05.2011. 13:32 ] @

hvala, cim pogledam kako funkcionise javljam jel sve u redu.

e jes stvarno smor, kad nesto saljes svaki bozji dan nekoliko puta dnevno. i tako godinama. pozelis da napravis nesto sto ce automatski da uradi.

[ Sudarica @ 06.06.2011. 17:20 ] @

Ivek,

znaš kako sam rješila problem potpisa
jednostavno sam u Kolonu "Names" (prije E-mail adrese) u svaki red kopirala kratku poruku i svoj potpis sa svim (prezime i ime, funkcija,broj telefona,e-mail adraesa ( u redu pomoću alt enter sve upisala jedno ispod drugog sa zahvalom i pozdravom) i izgleda super

Hvala Ivek puno puno

[ Sudarica @ 08.06.2011. 17:36 ] @

Molim još malo pažnje za slanje dokumenata

dodala sam radni list katalog u njemu su adrese i naziv dokumenta prema kojim bi trebala rasporediti dokumente iz Sheet "Files" u Sheet1 te pridružiti adrese iz kataloga.

U katalogu se nalaze adrese i primatelji (File Path ili put do dokumanta i njegov naziv) kojih ima više nego ih treba poslati jer nekada šaljem samo 50 e-mailova a nekada 350. Može se dogoditi da na jednu adresu ide 30 dokumanata, a isto tako jedan dokumenat na trideset adresa kako je napravljeno u katalogu.

Srdačan pozdrav

[ Ivek33 @ 09.06.2011. 12:07 ] @

Citat:

Sudarica: Molim još malo pažnje za slanje dokumenata

Postao sam u ovoj temi pa se osjećam prozvanim

Pitam se koji ti to posao radiš kada imaš takve potrebe?

Vidi nemam vremena ponovno se udubljivati u temu ali evo nekih brzinskih prijedloga jer ne znam koliko može biti opcija a vjerojatno bi se pomoću Macroa dalo fixirati

Dakle Sheet "katalog" je polazna točka u kojoj si odredila što ćeš kome slati
U stupac A postavi e-mail adrese a u stupac B FileName

PRVI NAČIN:

1. Napraviš na sheetu "katalog" tako da ti prvo bude u stupcu A e-mail pa stupac B FilesName
2. Selektiraš sve i Copy
3. Prijeđeš na Sheet1 ćelija B2 => pa Paste Special/Values
4. Sada imaš sve e-mail adrese na svom mjestu i FilesName (stupci B i C)
5. Selektiraš FilesName za jednu e-mail adresu i Transpose u D2 usporedno u istom redu
6. Sada imaš za dotičnu e-mail FilesName u istom redu a to odgovara onom Macrou koji šalje e-mailove
7. Pobrišeš duplikate e-mail adresa za koju si radila ovu radnju
8. Opet ideš dalje na Delete praznih među-redova
9. Ponoviš radnju za slijedeću e-mail adresu
10. Na kraju prije slanja obrišeš stupac C i imaš polaznu situaciju za slanje e-mailova preko Makronaredbe

Jeste da je "manualno" ali ako nema drugog načina "snađi se"

DRUGI NAČIN:

1.Upotrijebi Macro Function koja će automatski kopirati UNIQUE e-mail adrese na Sheet1 sa Sheeta "katalog"
2.Tada manualno sa Sheeta "katalog" transponiraš FileName za određenu e-mail adresu

Code:
Function UNIQUE(InputRange As Range, ItemNo As Long) As Variant
Dim cl As Range, cUnique As New Collection, cValue As Variant
 Application.Volatile
 On Error Resume Next
 For Each cl In InputRange
 If cl.Formula <> "" Then
 cUnique.Add cl.Value, CStr(cl.Value)
 End If
 Next cl
 UNIQUE = ""
 If ItemNo = 0 Then
 UNIQUE = cUnique.Count
 Else
 If ItemNo <= cUnique.Count Then
 UNIQUE = cUnique(ItemNo)
 End If
 End If
 On Error GoTo 0
End Function

formula za funkciju je:
(redom se povećava broj)
BTW: Raspon podataka na Sheetu "katalog" e-mail adresa sam imenovao nazivom "emailovi"

Code:

B2 => =UNIQUE(emailovi;1)
B3 => =UNIQUE(emailovi;2)
B4 => =UNIQUE(emailovi;3)
B5 => =UNIQUE(emailovi;4)
...

TREĆI NAČIN:

1.Upotrijebi Macro koji će nakon pokretanja kopirati UNIQUE e-mail adrese na Sheet1 sa Sheeta "katalog"
2.Tada manualno sa Sheeta "katalog" transponiraš FileName za određenu e-mail adresu

Code:
Sub KopirajUniqueText()
   For Each sh In Sheets(Array("katalog")) 'Sheet koji se pretražuje
           For Each cl In sh.Columns(1).SpecialCells(2) 'stupac koji se pretražuje 1=A
            If InStr(c01, cl.Value) = 0 Then c01 = c01 & "|" & cl.Value
        Next
    Next
    Sheets("Sheet1").Cells(2, 2).Resize(UBound(Split(c01, "|"))) = Application.Transpose(Split(Mid(c01, 2), "|")) 'Sheet na kojem želimo rezultat u (2,2) tj. B2
End Sub

Evo toliko o ovome od mene.
Vjerujem da bi se možda moglo riješiti i automatsko transponiranje ali to ti MOŽDA pomogne netko drugi

BTW: File ti je prevelik jer na Sheetu FILES imaš previše redova. Obriši redove koje ne koristiš pa će se file smanjiti (kao što su ovi moji)
U attachu (ZIP file) nalaze se svi načini koje sam ovdje opisao, pa pogledaj kako to izgleda u praksi.

[ Sudarica @ 11.06.2011. 10:08 ] @

Hvala puno na trudu radiću tako bilo bi mi puno jednostavnije kada bi i to radilo na klik ali ako nema vremena za to kaj se može i ovo je 95 posto više od onog što sam imala do sada.

Normalno ako ikada neko
poželi napisati naredbu i za ovaj zdanji korak (jednostavno upariti e-mail adrese iz kataloga s "File Path" iz Sheet (files) prema rasporedu iz kataloga kolone FileName1) bit ću presretna i zahvalna

srdačan pozdrav

[ Ivek33 @ 12.06.2011. 17:57 ] @

Citat:

Sudarica: bilo bi mi puno jednostavnije kada bi i to radilo na klik ali ako nema vremena za to kaj se može.......................(jednostavno upariti e-mail adrese iz kataloga s "File Path" iz Sheet (files) prema rasporedu iz kataloga kolone FileName1) bit ću presretna i zahvalna

Ako nemam ja ima netko drugi, a uz malo googlanja sve se nađe ;)
Evo macro koji kopira Unique e-mail adrese u jedan stupac i pridružuje transponirane pripadajuće FilesName

Code:
Option Explicit
Sub CopyUniqueTranspose()

 Dim Cell As Range
 Dim Data As Variant
 Dim Dict As Object
 Dim DstRng As Range
 Dim Key As Variant
 Dim Item As Variant
 Dim R As Long
 Dim Rng As Range
 Dim RngEnd As Range
 Dim Wks As Worksheet

 Set Wks = Worksheets("katalog")
 Set Rng = Wks.Range("A1")
 Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
 Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))

 Set DstRng = Worksheets("Sheet1").Range("B2")

 Set Dict = CreateObject("Scripting.Dictionary")
 Dict.CompareMode = vbTextCompare

 For Each Cell In Rng
 Key = Trim(Cell)
 Item = Array(Cell.Item(1, 2))
 If Not Dict.Exists(Key) Then
 Dict.Add Key, Join(Item, "|")
 Else
 Dict(Key) = Dict(Key) & "|" & Join(Item, "|")
 End If
 Next Cell

 For Each Key In Dict.Keys
 With DstRng.Offset(R, 0)
 .Value = Key
 Data = Split(Dict(Key), "|")
 .Offset(0, 1).Resize(1, UBound(Data) + 1).Value = Data
 R = R + 1
 End With
 Next Key
End Sub

[ Sudarica @ 16.06.2011. 18:25 ] @

Hvala Ivek

mislim da je ovo fantastična naredba

ali ima jedan veliki ALI. U katalogu su sve moguće datoteke i pripadajuće adrese ali u Sheetu "Files" se nalaze samo one koje moram poslati. Dali se njih može kopirati uz odgovarajuću e-mail adresu i pripremiti za slanje.

U svakom slučaju velika hvala

Srdačan pozdrav

[ Ivek33 @ 17.06.2011. 09:19 ] @

Citat:

Sudarica: Dali se njih može kopirati uz odgovarajuću e-mail adresu i pripremiti za slanje.

Kako će Excel znati koji FilesName pripadaju kojoj e-mail osim ako ti to ne definiraš nekako?
Stalno ima neki "ALI"

Teško je sada na kraju to ovako kada nisi odmah opisala organizaciju podataka a ni sada je ne kužim potpuno., osim da se neko "debelo" uhvati programiranja, a možda ima i drugi način

Napravi kopiju Sheeta "katalog" i kopiju imenuj nazivom "katalog-2". Ove radnje uvijek radiš na kopiji Sheeta "katalog"
Izdvoji na Sheetu "katalog-2" duplikate preko formule pa obriši višak stupaca i redova koji ti ne treba, pa sa njega povuci sve i transponiraj na Sheet1

Koliko sada shvaćam (ako dobro shvaćam) ti imaš unaprijed definirane e-mail adrese i pripadajuće files (paritete) i u principu znaš kojoj osobi koje files šalješ. Stvar je samo u datom trenutku koje files imaš u folderu??
Ja još jedino mogu pomoći na ovaj način (neka poluautomatizacija u nekoliko klikova)

1. Postavi ovu formulu u "C" stupac na Sheetu "katalog-2". (sheet "Katalog-2" tj. kopiju uvijek praviš iznova prije slanja e-maila)

Code:
=IF(ISERROR(MATCH(B1;FILES!$A$5:$A$200;0));"";B1)

kopiraj je prema dolje do zadnjeg reda.
Sada imaš duplikate tj. sve FilesName (sa Sheeta "FILES") koje trebaš poslati a ujedno su paritetni dotičnim e-mail adresama.

2. Sada imaš višak stupac "B" u kojem se nalaze svi FilesName, ovaj stupac bi trebalo obrisati no problem je što su rezultat formule a da bi sveli podatke na čistu vrijednost-text idi na ,
- Select trenutni stupac "C" => Copy => Paste Special u stupac "D" => Value
- ili pokretanjem Macroa "CopyCuD" kopiraj podatke iz C u D stupac

3. Obriši sada trenutne stupac "B" i "C" pa potom klik na button za pokretanje makronaredbe "deleteRow" da ti obriše prazne redove u u "B" stupcu (koji sada sadržava FilesName samo iz Sheeta FILES)
4. Sada si spremna za kopiranje i transponiranje na sheet1

Naravno dobro provjeri kako si prepravila makronaredbe i nazive sheets

Napomena: Ako makronaredbe pokrećeš preko buttona tada buttone postavi nekoliko redova ispod svih podataka na Sheetu "katalog-2" jer u protivnom će se obrisati kada budeš brisala redove (ili makronaredbe pokreći preko ALT+F8 )

Makronaredba u Module4 za kopiranje iz stupca "C" u stupac "D"

Code:
Sub CopyCuD()
With Sheets("katalog-2") 'izvorni Sheet
.Range(.Range("C1"), .Range("C65536").End(xlUp)).Copy 'izvorni stupac
End With
'destinacijski Sheet (u ovom slučaju je isti kao i izvorni)
Sheets("katalog-2").[D65536].End(xlUp)(1).PasteSpecial Paste:=xlValues 'prva ćelija u koju se kopira a to je D1
End Sub

Makronaredba u Module4 za brisanje praznih redova u stupcu "B"

Code:
Sub deleteRow()
ColumntoDelete = "B"
For i = Cells(Rows.Count, ColumntoDelete).End(xlUp).Row To 1 Step -1
If Cells(i, ColumntoDelete) = "" Then Cells(i, "B").EntireRow.Delete
Next i
End Sub

Grubi sažetak:
1. Očitaj folder za FilesName
2. Kopiraj podatke iz C u D
3. Obriši stupce B i C
4. Obriši prazne redove u sadašnjem stupcu B
5. Na Sheetu1 pokreni Macro za kopiranje i transponiranje sa Sheeta katalog-2
6 pošalji e-mailove

btw: pogledaj attach i prepravljenu makronaredbu u Module3 kao i nove makronaredbe u Module4

[ Sudarica @ 17.06.2011. 18:22 ] @

Ivek

to je ono što mi je nedostajalo

Code:
=IF(ISERROR(MATCH(B1;FILES!$A$5:$A$200;0));"";B1)

Hvala ti puno puno puno idem sada sve testirati. Normalno ako mi nekaj nebu jasno javljam se hvala još jednom.

Srdačan pozdrav