Příspěvky uživatele

Funguje, díky! ;-)

Ahoj, prosím o radu, co mám v makru níže špatně.
Nyní funguje pouze první podmínka.

If Value = SrcSh.[E50] = 0 Then

With Cells(st, 7)

.Value = "10"

.NumberFormat = "#,###"" text"""

End With

Else

With Cells(st, 7)

.Value = SrcSh.[E50]

.NumberFormat = "#,###"" text2"""

End With

Díky.

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.

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

Dobrá by byla příloha, ale nebyla by lepší funkce SVYHLEDAT?

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.

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.

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.

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.

Ano, je to možné..

Ahoj,

neřešil někdo podobné makro jako je toto?
https://groups.google.com/forum/#!topic/excelvbamacros/h7BF9ry0jhs

Jde mi o to vyhledat vzdálenost mezi dvěma městy, vynásobit ji dvěmi a určitou sazbou za 1km.

Tzn. 1 cesta = 50km * 2 (tam i zpět) * 10 (kč/km) = 1000kč

Definice města by mi stačila na základě názvu města a v případě více měst se stejným názvem bude nutné PSČ? Případně nějak vypsat všechny vzdálenosti mezi nalezenými městy?

Děkuji.

Myslel jsem, že lze spustit i ručně. Jsem blbej, omlouvám se a díky.. :)

To mám, ale v případě, že makro spustím, tak mi vyskočí okno s přehledem maker, kde žádné není na výběr, jako by nebylo "k dispozici" nebo jak to říct..?!

Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If IsEmpty(Worksheets("kus").Range("H8")) Then
Range("H8").Value = Environ("username")
Range("J8").Value = Date
Else
Range("H9").Value = Environ("username")
Range("J9").Value = Date
End If
End Sub

Upravil jsem na beforsave, ale stejně mi to nejde, ...?

Děkuji.

Ahoj,

prosím o radu, mám makro na vyplnění uživatelského jména v případě, že je již není vyplněno. Funguje pouze v případě, že makro spustím ručně, pokud dám uložit, tak nefunguje.

Sub Worksheet_Save()
If IsEmpty(Worksheets("kus").Range("H8")) Then
Range("H8").Value = Environ("username")
End If
End Sub

Potřeboval bych, aby při uložení se toto makro spustilo. Nějaký tip?

Děkuji.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje