Note: The other languages of the website are Google-translated. Back to English

Jak automaticky odesílat e-maily na základě hodnoty buňky v aplikaci Excel?

Předpokládejme, že chcete odeslat e-mail prostřednictvím aplikace Outlook určitému příjemci na základě zadané hodnoty buňky v aplikaci Excel. Například když je hodnota buňky D7 v listu větší než 200, automaticky se vytvoří e-mail. Tento článek představuje metodu VBA pro rychlé vyřešení tohoto problému.

Automaticky odesílat e-maily na základě hodnoty buňky s kódem VBA


Automaticky odesílat e-maily na základě hodnoty buňky s kódem VBA

Chcete-li odeslat e-mail na základě hodnoty buňky v aplikaci Excel, postupujte takto.

1. V listu musíte odeslat e-mail na základě jeho hodnoty buňky (zde se uvádí buňka D7), klepněte pravým tlačítkem na kartu listu a vyberte Zobrazit kód z kontextové nabídky. Viz snímek obrazovky:

2. Ve vyskakovacím okně Microsoft Visual Basic pro aplikace zkopírujte a vložte níže uvedený kód VBA do okna kódu listu.

Kód VBA: Odesílejte e-maily prostřednictvím Outlooku na základě hodnoty buňky v aplikaci Excel

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("D7"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > 200 Then
        Call Mail_small_Text_Outlook
    End If
End Sub
Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hi there" & vbNewLine & vbNewLine & _
              "This is line 1" & vbNewLine & _
              "This is line 2"
    On Error Resume Next
    With xOutMail
        .To = "Email Address"
        .CC = ""
        .BCC = ""
        .Subject = "send by cell value test"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Poznámky:

1). V kódu VBA, D7 a hodnota> 200 jsou hodnota buňky a buňky, na které budete posílat e-maily.
2). Změňte prosím text e-mailu, jak potřebujete xMailBody řádek v kódu.
3). Nahraďte e-mailovou adresu e-mailovou adresou příjemce v řádku .To = "E-mailová adresa".
4). A zadejte příjemce kopie a skrytá kopie, jak potřebujete .CC = "" a Skrytá kopie = “” sekce.
5). Nakonec změňte předmět e-mailu .Subject = "odeslat testem hodnoty buňky".

3. zmáčkni Další + Q klávesy společně zavřete Microsoft Visual Basic pro aplikace okno.

Od této chvíle, když je hodnota zadaná v buňce D7 větší než 200, bude v aplikaci Outlook automaticky vytvořen e-mail se zadanými příjemci a tělem. Můžete kliknout na Poslat tlačítko pro odeslání tohoto e-mailu. Viz screenshot:

Poznámky:

1. Kód VBA funguje, pouze když používáte Outlook jako svůj e-mailový program.

2. Pokud jsou zadaná data v buňce D7 textovou hodnotou, otevře se také e-mailové okno.


Snadno odesílejte e-maily prostřednictvím aplikace Outlook na základě polí vytvořeného seznamu adres v aplikaci Excel:

Projekt Odeslat e-maily užitečnost Kutools pro Excel pomáhá uživatelům odesílat e-maily prostřednictvím Outlooku na základě vytvořeného seznamu adres v aplikaci Excel.
Stáhněte si a vyzkoušejte! (30-denní stezka zdarma)


Související články:


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
officetab dno
Komentáře (305)
Hodnocení 5 z 5 · 1 hodnocení:
Tento komentář byl moderátorem webu minimalizován
Jak by měl být kód upraven, aby se vztahoval na celý rozsah buněk?
Tento komentář byl moderátorem webu minimalizován
Milá Debbie,
Zkuste problém vyřešit níže uvedeným kódem VBA.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
If (Not Intersect(Target, Range("A1:D4")) Is Nothing) And (Target.Value > 200) Then
Zavolejte Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
S xOutMail
.To = "E-mailová adresa vašeho příjemce"
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End Sub
Tento komentář byl moderátorem webu minimalizován
Mám potíže se zobrazením tohoto kódu, pokud se nepřímo změní hodnota v buňce. Například, pokud mám součtovou rovnici, která tuto hodnotu automaticky změní. Když rovnice běží a hodnota překročí nastavenou hodnotu, aby se vyžádal e-mail, neudělá to, pokud číslo fyzicky nezměním. Existuje způsob, jak vytvořit výzvu k e-mailu, i když se nepřímo změní?
Tento komentář byl moderátorem webu minimalizován
milý Jordane,
Následující kód VBA vám může pomoci vyřešit problém. Nezapomeňte prosím v kódu nahradit „E-mailovou adresu“ e-mailovou adresou příjemce. Děkuji.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim xRgPre As Range
On Error Resume Next
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRg = rozsah ("D7")
Nastavte xRgPre = xRg.Precedenty
Pokud xRg.Value > 200 Pak
If Target.Address = xRg.Address Then
Zavolejte Mail_small_Text_Outlook
ElseIf (Not xRgPre Is Nothing) And (Intersect(Target, xRgPre).Address = Target.Address) Then
Zavolejte Mail_small_Text_Outlook
End If
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
S xOutMail
.To = "E-mailová adresa"
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End Sub
Tento komentář byl moderátorem webu minimalizován
Upravil jsem navrhovaný kód, abych se pokusil, aby fungoval pro moji aplikaci.
Změněno xRg = Range("C2:C40") a If xRg.Value = -1.

Problém, který mám, je kdykoli dojde ke změně jakékoli buňky, a pokud je jedna z buněk v mém rozsahu = -1, zavolá se Mail_small_Text_Outlook.
Snažím se volat pouze v případě, že se některá buňka v mém rozsahu nepřímo změní na -1.
Také mě zajímalo, jestli a jak by bylo možné, aby to splňovalo dvě kritéria.
Stejně jako kontrola rozsahu A a rozsahu B a pokud splňují kritéria volání funkce.

Předem děkuji za pomoc. Jsem v tomhle všem nováček, ale při čtení tohoto vlákna mám asi 90 % tam.


Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim xRgPre As Range
On Error Resume Next
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRg = Range("C2:C40")
Nastavte xRgPre = xRg.Precedenty
Pokud xRg.Value = -1 Pak
If Target.Address = xRg.Address Then
Zavolejte Mail_small_Text_Outlook
ElseIf (Not xRgPre Is Nothing) And (Intersect(Target, xRgPre).Address = Target.Address) Then
Zavolejte Mail_small_Text_Outlook
End If
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Použil jsem tento kód s jedinou změnou, kterou jsem použil na celý sloupec [Set xRg = Range("D4:D13")]. Nyní se událost spustí vždy, když je proveden výpočet bez ohledu na to, zda je ventil ve sloupci D pod cílovou hodnotou. Nějaký nápad, proč tomu tak je?


Dim Xrg jako rozsah
Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim xRgPre As Range
On Error Resume Next
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit Xrg = rozsah("D4:D13")
Nastavte xRgPre = Xrg.Precedenty
Pokud Xrg.Value < 1200 Pak
If Target.Address = Xrg.Address Then
Zavolejte Mail_small_Text_Outlook
ElseIf (Not xRgPre Is Nothing) And (Intersect(Target, xRgPre).Address = Target.Address) Then
Zavolejte Mail_small_Text_Outlook
End If
End If
End Sub

Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & _
"Test vba" _
& vbNewLine & _
"Řádek 2."
On Error Resume Next
S xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Automatický test e-mailu"
.Tělo = xMailBody
.Zobrazit
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic

End Sub


Díky.
Tento komentář byl moderátorem webu minimalizován
Ahoj

Mám potíže, protože příjemce e-mailu musí být přidáván znovu a znovu jeden po druhém. Poraďte, zda lze do této funkce přidat seznam příjemců e-mailu, aby funkce vybrala e-mailovou adresu ze seznamu poskytnutých e-mailových adres nebo nahrála seznam a funkce odeslala již sestavený e-mail požadovanému příjemci.
Tento komentář byl moderátorem webu minimalizován
milý Henry,
Následující kód VBA vám může pomoci vyřešit problém. Umístěte skript VBA do modulu listu. Když hodnota v zadané buňce splní podmínku, objeví se dialogové okno Kutools pro Excel, vyberte buňky, které obsahují e-mailové adresy příjemců, a klikněte na tlačítko OK. Poté se otevírají e-maily se zadanými příjemci. Odešlete je prosím, jak potřebujete.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRg = rozsah ("D7")
Pokud xRg = Target And Target.Value > 200 Then
Zavolejte Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Dim xRgMsg jako rozsah
Dim xCell As Range
Set xRgMsg = Application.InputBox("Vyberte buňky adresy:", "Kutools pro Excel", , , , , , 8)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
Pro každý xCell In xRgMsg
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
S xOutMail
.To = xCell.Value
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
xOutApp = Nic
xOutMail = Nic
další
Při chybě GoTo 0
End Sub
Tento komentář byl moderátorem webu minimalizován
bude odeslána automaticky poštou, bez jakéhokoli ručního přerušení
Tento komentář byl moderátorem webu minimalizován
drahý brahmo,
Pokud chcete odeslat e-mail přímo bez zobrazení, nahraďte prosím řádek „.Display“ textem „.Send“ ve výše uvedeném kódu VBA.
Tento komentář byl moderátorem webu minimalizován
Ahoj, vložil jsem stejný skript, ale nefunguje, prosím pomozte mi v 1. části

Dim xRg jako rozsah

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRg = rozsah ("D7")
Pokud xRg = Target And Target.Value = 200 Then
Zavolejte Mail_small_Text_Outlook
End If

End Sub
Tento komentář byl moderátorem webu minimalizován
drahá bazalka,
Existuje nějaké varování při spuštění kódu?
Tento komentář byl moderátorem webu minimalizován
Dobrý den, jak byste upravili tento kód, abyste zkontrolovali, zda skupina buněk obsahuje řetězec "No match" a poslali e-mail, pokud ano.
Tento komentář byl moderátorem webu minimalizován
Vážený Jose,
Zkuste prosím níže uvedený kód VBA. Při spuštění kódu se objeví dialogové okno, vyberte rozsah, ve kterém budete kontrolovat řetězec, a klikněte na tlačítko OK. pokud řetězec neexistuje, zobrazí se dialogové okno s výzvou. Pokud řetězec v rozsahu existuje, zobrazí se e-mail se zadaným příjemcem, předmětem a tělem.

Sub SendEmail()
Dim I As Long
Dim J As Long
Dim xRg jako rozsah
Dim xArr
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Dim xFlag As Boolean
On Error Resume Next
Set xRg = Application.InputBox("Vyberte rozsah", "Kutools pro Excel", Selection.Address, , , , , 8)
Pokud xRg není nic, pak Exit Sub
xArr = xRg.Hodnota
xFlag = False
Pro I = 1 až UBound(xArr)
Pro J = 1 až UBound(xArr, 2)
Pokud xArr(I, J) = "No Match" Pak
xFlag = Pravda
End If
další
další
Pokud xFlag Then
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
S xOutMail
.To = "E-mailová adresa"
.CC = ""
.BCC = ""
.Předmět = "Shoda"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Jiný
MsgBox "Nenalezena žádná odpovídající hodnota", vbInformation, "KuTools for Excel"
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Jak mohu změnit tento kód pro zasílání hodnocení studentů rodičům. Kde, pokud sloupec A je hodnocení a sloupec B je nadřazený e-mail. Chci vyplnit e-mail pro každého studenta s F jako známkou.
Tento komentář byl moderátorem webu minimalizován
milý Franku,
Níže uvedený kód VBA vám může pomoci vyřešit problém. Děkuji.

Sub Mail_small_Text_Outlook()
Dim xRg jako rozsah
Dim I As Long
Dim xRows As Long
Dim xVal As String
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
On Error Resume Next
Set xRg = Application.InputBox("Vyberte prosím sloupec hodnocení a sloupec e-mailu (dva sloupce)", "Kutools pro Excel", Selection.Address, , , , , 8)
Pokud xRg není nic, pak Exit Sub
xRows = xRg.Rows.Count
Nastavit xRg = xRg(2)
Pro I = 1 až xRows
xVal = xRg.Offset(I, -1).Text
Pokud xVal = "F" Pak
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je známka vašeho dítěte" & xRg.Offset(I, -1).Text
S xOutMail
.to = xRg.Offset(I, 0).Text
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
Mám seznam e-mailových adres již v souboru aplikace Excel, jak mohu upravit kód tak, aby automaticky vybral e-mailovou adresu osoby, pokud je její buňka D7 > 200?
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Následující kód VBA vám může pomoci vyřešit problém. Umístěte skript VBA do modulu listu. Když hodnota v zadané buňce splní podmínku, objeví se dialogové okno Kutools pro Excel, vyberte buňky, které obsahují e-mailové adresy příjemců, a klikněte na tlačítko OK. Poté se otevírají e-maily se zadanými příjemci. Odešlete je prosím, jak potřebujete.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRg = rozsah ("D7")
Pokud xRg = Target And Target.Value > 200 Then
Zavolejte Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Dim xRgMsg jako rozsah
Dim xCell As Range
Set xRgMsg = Application.InputBox("Vyberte buňky adresy:", "Kutools pro Excel", , , , , , 8)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
Pro každý xCell In xRgMsg
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
S xOutMail
.To = xCell.Value
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
xOutApp = Nic
xOutMail = Nic
další
Při chybě GoTo 0
End Sub
Tento komentář byl moderátorem webu minimalizován
Mám problém s odesíláním pošty přes outlook. Zobrazuje se mi chyba „Program se pokouší odeslat e-mail vaším jménem. Pokud je neočekávaný, odmítněte a ověřte, zda je váš antivirový software aktuální.“
Prosím o pomoc, protože to neumím zautomatizovat.
Tento komentář byl moderátorem webu minimalizován
Promiň mayanku,
Kód v mém případě funguje dobře. Zdá se, že ve vašem Outlooku je nakonfigurováno něco o funkci „odeslat jménem“. Pease to zkontrolujte.
Tento komentář byl moderátorem webu minimalizován
Dobrý den, jaký kód bych použil, když se pokouším poslat e-mail manažerovi, který má seznam ovoce, které má množství > 200, jednou za měsíc (na základě vašeho příkladu) nebo brzy vyprší (na základě dat)
Tento komentář byl moderátorem webu minimalizován
Dobrý den
Může být metoda v tomto článku "Jak odeslat e-mail, pokud bylo v Excelu splněno datum splatnosti?" mohu vám pomoci.
Následujte prosím tento odkaz: https://www.extendoffice.com/documents/excel/4664-excel-send-email-if-due-date-has-been-met.html
Tento komentář byl moderátorem webu minimalizován
Jak mohu upravit kód pro odeslání e-mailu na základě data v buňce. Potřebuji například dokument revidovat každých 15 měsíců a chci po 12 měsících odeslat e-mail na e-mailovou adresu, že dokument musí být zkontrolován. Mám to teď, abych automaticky posílal e-mail změnou .Display na .Send a funguje to skvěle, jak je napsáno, ale co musím změnit, abych používal funkci data místo celého čísla?
Tento komentář byl moderátorem webu minimalizován
Jak můžete přidat více rozsahů do "Set xRg = Range("D7")". Chci to upravit a přidat Range("D7:F7"). Zobrazuje se mi však chyba Run Time Error 13, Type Mismatch a dostává mě to do If xRg = Target And Target.Value > 2 Then.


Jak mohu tento problém vyřešit?
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Zkuste problém vyřešit níže uvedeným kódem VBA.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
If (Not Intersect(Target, Range("D7:F7")) Is Nothing) And (Target.Value > 200) Then
Zavolejte Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
S xOutMail
.To = "E-mailová adresa vašeho příjemce"
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End Sub
Tento komentář byl moderátorem webu minimalizován
fungovalo to perfektně.. děkuji..:):)
Tento komentář byl moderátorem webu minimalizován
Nefunguje mi to, protože hodnota v D7 je výsledkem vzorce. Co když buňka D7 obsahuje vzorec, např. D7 =2*120? Stále to splňuje podmínku, ale nic se neděje. Prosím pomozte
Tento komentář byl moderátorem webu minimalizován
jak zastavit běh kódu, tj. nevyzývat e-mail, když není splněna podmínka?

i když D7 < 200, stále dostávám výzvu k odeslání e-mailu.
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Kód je aktualizován v příspěvku s vyřešeným problémem. Děkuji za váš komentář.
Tento komentář byl moderátorem webu minimalizován
Hi

Mnohokrát děkujeme za zveřejnění tohoto kódu VBA a pokynů. Když jsem to našel, měl jsem pocit, že jsem vyhrál v loterii. Na něčem jsem se však zasekl, takže doufám, že mi můžete pomoci (jsem nováčkem ve VBA, rozumím jen velmi základním).

Zkopíroval jsem kód a změnil jsem hodnotu buňky a buňky tak, aby byly vybrány z rozsahu, pokud jsou splněna kritéria. Vyzkoušel jsem a otestoval a funguje to a dostal jsem e-mail do aplikace Outlook na základě kritérií.

1) Zdá se mi však, že nemohu přijít na to, jak zajistit, aby se kód VBA spouštěl automaticky, když otevřu excelový list, než abych musel kliknout na aplikaci VBA a vybrat spustit. Mohli byste poradit, zda existuje další výzva k zadání výše uvedeného kódu VBA, která to udělá, nebo to musí být provedeno samostatně.

2) Existuje také způsob, jak získat kód VBA pro odeslání e-mailu osobě, pokud je datum splatnosti pro určitou položku ano, jak je znázorněno v příkladu níže.
e-mail skrytý sloupec
Název produktu

Postup
Postup č.1 termín splatnosti ano
Postup č. 2 termín splatnosti č

V tabulce bych měl mnoho lidí (procházející horizontálně v řadě) a 'Ano' by mohlo být zvýrazněno pro různé zpožděné procedury (uvedené svisle ve sloupci A. Existuje způsob, jak vytvořit kód VBA, který běží pro něco takového - pokud „Ano“ pro „Osobu 1“, pošlete „osobě 1“ e-mail s „číslem postupu“ (nebo čísly) a datem splatnosti. V e-mailu budete moci uvést všechny postupy a jejich následná data splatnosti.

Nevadilo by mi, kdybych musel pro každou osobu nastavit samostatný kód VBA, pokud by to poslalo e-mail se všemi dokumenty po splatnosti pro tuto osobu a datem splatnosti.

Doufám, že vám pomůže
Tento komentář byl moderátorem webu minimalizován
Drahá ann,
Zkuste prosím níže uvedený kód VBA. Děkuji za váš komentář.

Sub Mail_small_Text_Outlook()
Dim xRg jako rozsah
Dim xCell As Range
Dim I As Long
Dim xRows As Long
Dim xCols As Long
Dim xVal As String
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
On Error Resume Next
Set xRg = Application.InputBox("Vyberte rozsah obsahuje hodnotu buňky, na základě které budete posílat e-maily:", "Kutools pro Excel", Selection.Address, , , , , 8)
Pokud xRg není nic, pak Exit Sub
xRows = xRg.Rows.Count
xCols = xRg.Columns.Count
Pro I = 1 až xRows
Nastavit xCell = xRg(I, xCols)
Pokud xCell.Value = "Ano" Pak
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto jsou vaše informace: " & vbNewLine & xCell.Offset(0, -1).Text & vbNewLine & xCell.Offset(0, -2).Text
S xOutMail
.To = xCell.Offset(0, -4).Text
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
Krystal,

Toto nahrazuje následující kód:

Dílčí e-mail()

Dim xRg jako rozsah

Dim xRgEach As Range

Dim xEmail_Subject, xEmail_Send_Form, atd.
Tento komentář byl moderátorem webu minimalizován
Kam přesně vložíme tento kód?
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Musíte umístit kód do okna kódu listu.
Otevřete okno Microsoft Visual Basic for Applications, dvakrát klikněte na název listu v levém podokně a otevřete editor kódu.
Tento komentář byl moderátorem webu minimalizován
Ahoj,


Momentálně mám s kódováním trochu problémy (novinka – možná jsem si ukousl víc, než dokážu rozkousat)


Momentálně mám tabulku s následujícími údaji, které potřebuji pomoci s automatizací a odesíláním e-mailů o chybách, které jsou v našich vlastnostech pro naši firmu


Aktuálně potřebuji kód, který bude používat následující data:


1) Adresa a problém ( 2 "obecné" buňky, které byly sloučeny přes ((v buňce D1)) " = =CONCAT(B1," "C1,) "
Adresa v B1 bude vždy stejná (více či méně)
Zatímco C1 se bude vždy měnit v závislosti na poruše v objektu.


2) E-mail, který má být zaslán stejnou e-mailovou adresou (mohu použít $E$1 nebo musím použít například E1 - E1) nebo mohu do řádku kódu zadat "TheEmailAdress@.co.uk"


3) Tělo e-mailu, které se vyplní podobně jako v bodě 1) ...... ((V buňce F1)) " =CONCAT(G1," ",H1)
Ty se budou neustále měnit, protože představují společnost (G1) a co dělají, opravují, citují atd. (H1)

4) Spouštěč pro odeslání e-mailu, já bych byl číslo 7, list se aktualizuje denně (7 dní v týdnu)
jako takový potřebuji spouštěč k odeslání e-mailu v den 7, ale ne neustále jako v den 8, 9, 10+ atd. a ne dříve než jako 1-6, to by bylo v A4: A 100+ (protože neustále rozšiřujeme


4) Použil jsem malé úryvky od jiných uživatelů, kteří se zmínili o použití seznamu pro spouštěč k odeslání e-mailu, ale nejsem si jistý, zda je to 100% správné, ale potřeboval bych to naskenovat přes všechny Collum A... A4: A100
a pokud existuje 47 buněk, které obsahují pouze " 7 ", bude odesláno 47 e-mailů


Mockrát děkuji za přečtení a doufám, že mi pomůžete :)
Tento komentář byl moderátorem webu minimalizován
milý martyne,
Promiň, s tím ti nepomůžu.
Svou otázku můžete vložit do našeho fóra: https://www.extendoffice.com/forum.html získat další podporu Excelu od našeho technického personálu.
Děkujeme za váš komentář.

S pozdravem,
Krystal
Tento komentář byl moderátorem webu minimalizován
Dobrý den,


Co když chci odeslat e-mail na základě slova „dokončeno“, které bylo přidáno do sloupce L?
Tento komentář byl moderátorem webu minimalizován
milý Jesse,
Následující kód VBA vám může pomoci vyřešit problém. Děkuji za váš komentář.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
If (Not Intersect(Target, Range("L:L")) Is Nothing) And (Target.Value = "completed") Then
Zavolejte Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
S xOutMail
.To = "E-mailová adresa vašeho příjemce"
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End Sub
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Chtěl bych, aby se Outlook zobrazil pouze tehdy, když data, která jsem vložil do rozsahu ("D7:F7"), mají alespoň 1 nulu nebo prázdné místo.
Odstranil jsem řádek 'If Target.Cells.Count > 1 Then Exit Sub' a nyní se Outlook spustí vždy, když vložím jakoukoli skupinu hodnot do buněk D7:F7.

Help.
Tento komentář byl moderátorem webu minimalizován
milá Jano,
Následující skript vám může pomoci vyřešit problém. Děkuji za váš komentář.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
On Error Resume Next
If Target.Address = Range("D7:F7").Address Then
S funkcí Application.WorksheetFunction
If .CountIf(Target, "") > 0 Nebo .CountIf(Target, 0) > 0 Pak
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
S xOutMail
.To = "E-mailová adresa"
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Body = "Ahoj"
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End If
Konec s
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Použil jsem tedy vaši úpravu k zahrnutí rozsahů buněk, ale (pokud používáme příklad listu), zajímalo by mě, jak přidat druh ovoce, datum a množství do e-mailu HTML z listu, pokud splňují kritéria nechat si vygenerovat email. Řeklo by se tedy

"Ahoj,"

Název ovoce z buňky "Je třeba doobjednat, protože k datu objednávky: " datum objednávky z buňky "máme toto množství:" množství z buňky.
Tento komentář byl moderátorem webu minimalizován
Ahoj Noemi,
Zkuste prosím tento skript VBA.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim xRg jako rozsah
Dim I, J, K As Long
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
On Error Resume Next
If Target.Address = Range("D7").Address Then
S funkcí Application.WorksheetFunction
If IsNumeric(Target.Value) And Target.Value > 200 Then
Set xRg = Application.InputBox("Vyberte rozsah buněk, který chcete zobrazit v těle e-mailu:", "KuTools for Excel", Selection.Address, , , , , 8)
Pokud xRg není nic, pak Exit Sub
Pro I = 1 To xRg.Rows.Count
Pro J = 1 To xRg.Rows(I).Columns.Count
Pro K = 1 To xRg.Rows(I).Columns(J).Count
xMailBody = xMailBody & " " & xRg.Rows(I).Columns(J).Cells(K).Text
další
další
xMailBody = xMailBody & vbNewLine
další
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
S xOutMail
.To = "E-mailová adresa"
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Body = "Ahoj" & vbNewLine & xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End If
Konec s
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
ahoj krystale
děkujeme za vaše kódy, pokud je to možné, laskavě pošlete kódy pro níže uvedené podrobnosti

pokud máme 8 až 9 sloupců používajících různé typy vypršení platnosti, jako je datum vypršení platnosti pasu, datum vypršení platnosti řidičského průkazu, datum vypršení platnosti registrace vozidla, datum vypršení platnosti brány a další atd., a upozornění e-mailem musí být zasláno pouze 5 daným osobám.

jako je náš datový list s více než 300 zaměstnanci, expirace a datum vypršení platnosti za 15 dní v červené barvě a upozornění by mělo být zasláno e-mailem.

laskavě udělej potřebné

díky předem
Tento komentář byl moderátorem webu minimalizován
Ahoj,
Zveřejnili jsme článek "Jak odeslat e-mail, pokud bylo v Excelu dodrženo datum splatnosti?"
Zda existují odpovědi, se můžete podívat v tomto článku. Chcete-li otevřít článek, klikněte na tento odkaz: https://www.extendoffice.com/documents/excel/4664-excel-send-email-if-due-date-has-been-met.html
Děkuji.
Tento komentář byl moderátorem webu minimalizován
Dobrý den, pokud bych chtěl poslat na e-mail ze seznamu místo uvedení skutečného e-mailového addy do kódu, je to možné? dík
Tento komentář byl moderátorem webu minimalizován
Ahoj,
Zkuste prosím níže kód VBA, když zadaná buňka splňuje podmínku, objeví se dialogové okno, vyberte prosím buňku obsahující e-mailovou adresu, na kterou budete e-mail posílat. Doufám, že to může pomoci. Děkuji.

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRg = rozsah ("D7")
Pokud xRg = Target And Target.Value > 200 Then
Zavolejte Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Dim xRgMsg jako rozsah
Dim xCell As Range
Set xRgMsg = Application.InputBox("Vyberte buňky adresy:", "Kutools pro Excel", , , , , , 8)
xMailBody = "Ahoj" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2"
On Error Resume Next
Pro každý xCell In xRgMsg
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
S xOutMail
.To = xCell.Value
.CC = ""
.BCC = ""
.Subject = "odeslat testem hodnoty buňky"
.Tělo = xMailBody
.Zobrazte 'nebo použijte .Send
Konec s
xOutApp = Nic
xOutMail = Nic
další
Při chybě GoTo 0
End Sub
Zatím zde nejsou žádné komentáře
Načíst další
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL