< návrat zpět

MS Excel

Téma: VBA - sum, podbarvení, podpis emailu rss

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.

Zaslat odpověď >
zEjnik(19.3.2014 14:57)#018391
avatar
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.citovat
Palooo(19.3.2014 15:21)#018395
avatar
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 alecitovat
Opičák(19.3.2014 15:39)#018399
Opičák
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 nezkoumalcitovat
zEjnik(5.4.2014 13:39)#018664
avatar
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: zip18664_podpis.zip (15kB, staženo 26x)
citovat
dream2003(5.4.2014 18:09)#018666
avatar
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 Subcitovat
zEjnik(5.4.2014 22:57)#018668
avatar
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.citovat
zEjnik(6.4.2014 13:52)#018678
avatar
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
citovat
zEjnik(6.4.2014 19:04)#018695
avatar
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

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje