< návrat zpět
MS Excel
Téma: VBA - sum, podbarvení, podpis emailu 
Zaslal/a zEjnik 19.3.2014 6:07
Ahoj,
mám pár věci s kterými bych potřeboval poradit.
1) Mám makro, které mi kopíruje z určité oblasti data a na konci sčítá, ale potřeboval bych sčítat pouze buňky, které buď obsahují nebo mají formát buňky " .NumberFormat = "#,###"" Kč""" " Zkoušel jsem: If WorksheetFunction.Sum(Range("F9:F" & st)) & .NumberFormat = "#,###"" Kč""" < 0 Then ale to bohužel nejde. (v některých buňkách ve sloupci "F" mám hodnoty, které určují vzdálenost a mají formát např. "1000 mm")
2) Stejný případ jako nahoře, mám oblast, kterou kopíruji a na konci té oblasti potřebuji podbarvit pozadí, ale nikdy nevím jak tam oblast bude velká. Jak na konci definovat oblast, když dopředu neznám její velikost?
3) Mám makro na vytvoření PDF, otevření emailu, vložení přílohy, text atd. ale automaticky se nevkládá podpis. Když už se mi tam podařilo podpis dostat, tak v Outlooku mám 3 emailové účty a nevím jak zvolit, který účet chci použít? (nyní makro neobsahuje podpis)
Šlo by udělat, aby se mi PDF uložilo do místa, kde se nachází soubor .xlsx a neukládal se do tempu?
Sub OdesliEmail()
Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.
TempFilePath = Environ$("temp") & "\"
' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.
TempFileName = "NAB" & Cells(1, 7).Value & ".pdf"
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
'Now Export the Activesshet as PDF with the given File Name and path
On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
'Now open a new mail
Set OlApp = CreateObject("Outlook.Application")
Set NewMail = OlApp.CreateItem(0)
On Error Resume Next
With NewMail
.To = Cells(5, 2).Value
.Subject = "Cenová nabídka" & " " & Cells(1, 7).Value
.body = "Dobrý den," & vbNewLine & vbNewLine & ....
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.Display 'or use .Display to show you the email before sending it.
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder
Kill FileFullPath
'set nothing to the objects created
Set NewMail = Nothing
Set OlApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
err:
MsgBox err.Description
End Sub
Děkuji za pomoc.
zEjnik(19.3.2014 14:57)#018391 
Už jsem se přiblížil tomu, jak sčítat buňky, když v buňce bude "kč"
With Cells(st, 6)
If Right(cell.NumberFormat, 2) = "kč" Then
.WorksheetFunction.Sum (Range("F9:F" & st)) < 0
.Cells(st + 3, 5).Value = "Cena:"
.Font.Bold = True
End With
ale je to nějaký mišmaš..
Podařil by mi prosím někdo jak to správně poskládat?
Děkuji.
citovatPalooo(19.3.2014 15:21)#018395 With Cells(st, 6)
if .NumberFormat = "#,###"" Kč"""
--- tu podmienka
end if
end with
ale neskusal som to .... podla mna ta format formula je zle napisana ... treba ju upravit
2) po pri procese stale napocitavame nejake cislo a zitujeme zaciatok range a koniec range a potom len pouzijeme to cislo .... v mojom priklade to je premenna Z
for x = 1 to 200
z = z + 1
next
3) asi takto:
.Body = MyText & .Body
je mozmne ze ked nastavujete body tak si prepisete podpis s body ... nuskusal som ale
citovat Opičák(19.3.2014 15:39)#018399 
Mě to na ten formát měny funguje tak jak to máš, ale s úpravou: (zde u mě pro sl. A)
If Right(Cells(lin, "A").Text, 3) = "Kč " Then
right 3, protože za "Kč" je ještě mezera, takže "Kč "
to ostatní v kodu jsem nezkoumal
citovatzEjnik(5.4.2014 13:39)#018664 Ahoj,
trochu obnovím téma. Vytvořil jsem vzorový soubor, kde je makro pro vytvoření PDF, uložení do umístění, kde je uložen *.xlsx soubor, vložení do emailu + textu emailu a chybí mi přidání podpisu, které jsem se snažil vložit, ale nefunguje mi.
Díky moc.
Příloha: 
18664_podpis.zip (15kB, staženo 25x) citovatdream2003(5.4.2014 18:09)#018666 dobrý den, tady makro s vyřešeným podpisem
Dim myOutlook As Object
Dim myMailItem As Object
Dim signature As String
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.createitem(olMailItem)
Rem podpis v html
With otlNewMail
.display
End With
signature = otlNewMail.htmlbody
Rem text zpravy v html
textzpravy = "Dobrý den," & "<br><br>" & "v příloze report za včerejšek"
With otlNewMail
.To =
.CC = " '(email id of cc person)
.Subject = "report - " & Format(Now - 1, "dd.mm.yyyy") 'predmet text + datum -1
.htmlbody = "<html><body>" & textzpravy & signature 'vlastní email
.Attachments.Add ActiveWorkbook.FullName 'přidá přílohu
.display 'zobrazí email .send ihned odesílá
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
End SubcitovatzEjnik(5.4.2014 22:57)#018668 Na netu je plno maker s podpisem, ale zajímalo by mě, proč to nefunguje v tom mém. Navíc zde už mám vše nastavené, jde o to jenom přidat podpis a je dokonalé.. :-)
Díky za ochotu, ale spíš bych chtěl zjistit jak přidat podpis do mého makra.
PS: Je možné v tomto makru jak je vytvořené změnit v Outlooku velikost písma na 11pt nebo je nutné použít HTMLBody?
Díky.
citovatzEjnik(6.4.2014 13:52)#018678 Email vyřešen, kdyby někdo někdy potřeboval.
Sub OdesliEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.
TempFilePath = ThisWorkbook.Path & "\"
' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.
TempFileName = "text" & Cells(1, 7).Value & ".pdf"
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
'Now Export the Activesshet as PDF with the given File Name and path
On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "text emailu"
On Error Resume Next
With OutMail
.Display
.To = Cells(5, 2).Value
.Subject = "předmět" & " " & Cells(1, 7).Value
.HTMLBody = strbody & "<br>" & .HTMLBody
.Attachments.Add FileFullPath
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
err:
MsgBox err.Description
End Sub
citovatzEjnik(6.4.2014 19:04)#018695 Poslední věc s čím bych potřeboval poradit je, jak do tohoto řádku přidat kritérium,
If WorksheetFunction.Sum(Range("F9:F" & st)) < 0 Then
které zde dával Opičák.
If Right(Cells(lin, "A").Text, 3) = "Kč " Then
Přemýšlel jsem o funkci WorksheetFunction.SumIfs, ale nepodařilo se mi to dát dohromady.
Podmínka je: sečti buňky, které obsahují "Kč" a zároveň jejich součet je menší než 0, potom...
Díky.
citovat
RSS nejnovější články