Hirdetés
- laca223: Miért győz a kollektív meggyőződés akkor is, ha saját magát teszi tönkre?
- Sub-ZeRo: Euro Truck Simulator 2 & American Truck Simulator 1 (esetleg 2 majd, ha lesz) :)
- Luck Dragon: Asszociációs játék. :)
- sziku69: Fűzzük össze a szavakat :)
- GoodSpeed: Munkaügyi helyzet Hajdú-Biharban: észak és dél
- sziku69: Szólánc.
- Magga: PLEX: multimédia az egész lakásban
- Geri Bátyó: Agglegénykonyha 10 – Alapanyagok/készételek többféle felhasználása
- urandom0: Száműztem az AI-t az életemből
- djculture: Éhezők ssd és memória viadala.
Új hozzászólás Aktív témák
-
Amiens
tag
Újabb felvetés:
Egy munkalapon szeretnék keresni adott oszlopra és sorra, így a keresett érték a két tömb csomópontja lenne...

-
Amiens
tag
válasz
sztanozs
#2721
üzenetére
Köszönöm szépen!

Tökéletesen működik! Mivel van meghatalmazásom a másik e-mail cím használatához, így patentul beírtam ezt a kódrészletet:If Sheets("Alap").Range("D1") = "Másik cím <másvalaki@valaki.hu>" Then
.SentOnBehalfOfName = Sheets("Alap").Range("D1")
End If
Mindezt betettem egy cellalistába, és voálá, annyit és azt teszek bele, akit akarok...
-
Amiens
tag
válasz
sztanozs
#2719
üzenetére
Parancsoljatok!

Sub level()
sor = 2
kinek = Sheets("Alap").Range("b6")
Set OutApp = CreateObject("Outlook.Application")
While Not IsEmpty(Sheets(kinek).Cells(sor, 2))
If Sheets(kinek).Cells(sor, 1) = "Igen" And IsEmpty(Sheets(kinek).Cells(sor, 6)) Then
keres = Sheets(kinek).Cells(sor, 2)
Set OutMail = OutApp.CreateItem(0)
With OutMail
If Sheets("Alap").Range("b8") = "Nem" Then
.To = Sheets(kinek).Cells(sor, 3)
Else
.To = "valaki@valami.hu"
End If
If Sheets("Alap").Range("b7") = "Igen" Then
.CC = Sheets(kinek).Cells(sor, 4)
End If
.Subject = Sheets("Alap").Range("b1") & "-" & Sheets(kinek).Cells(sor, 2)
.HTMLBody = ""
.HTMLBody = .HTMLBody & Replace(Sheets("Alap").Range("b2"), Chr(10), "<br>") & "<BR>"
.HTMLBody = .HTMLBody & Replace(Sheets(kinek).Cells(sor, 5), Chr(10), "<br>") & "<BR>"
.HTMLBody = .HTMLBody & Replace(Sheets("Alap").Range("b3"), Chr(10), "<br>") & "<BR>"
If Not IsEmpty(Sheets("Alap").Range("b4")) Then
wb1 = ActiveWorkbook.Name
Workbooks.Open (Workbooks(wb1).Sheets("Alap").Range("b4"))
wb2 = ActiveWorkbook.Name
s = 1
kuld = False
While Not IsEmpty(Workbooks(wb1).Sheets("Alap").Cells(s + 9, 1))
sh = Workbooks(wb1).Sheets("Alap").Cells(s + 9, 1)
Select Case Workbooks(wb1).Sheets("Alap").Cells(s + 9, 3)
Case "Nem kell"
Workbooks(wb2).Sheets(sh).Select
Application.DisplayAlerts = False
Workbooks(wb2).Sheets(sh).Delete
Application.DisplayAlerts = True
Case "Mind"
Case "Szűrő"
oszlop = Workbooks(wb1).Sheets("Alap").Cells(s + 9, 2)
Workbooks(wb2).Sheets(sh).Select
msor = Workbooks(wb1).Sheets("Alap").Cells(s + 9, 4)
msor = msor & ":" & msor
Rows(msor).Select
Selection.AutoFilter
ActiveSheet.Range("$A:$XB").AutoFilter Field:=oszlop, Criteria1:="<>" & keres
Range(Cells(Workbooks(wb1).Sheets("Alap").Cells(s + 9, 4) + 1, 1), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.EntireRow.Delete
[A1].Select '.pdf miatt
ActiveSheet.PageSetup.Orientation = xlLandscape '.pdf miatt
ActiveSheet.PageSetup.FitToPagesWide = 1 '.pdf miatt
ActiveSheet.ShowAllData
End Select
s = s + 1
Wend
Filename = ActiveWorkbook.Path & "/" & Workbooks(wb1).Sheets("Alap").Range("B5")
Application.DisplayAlerts = False
If Workbooks(wb1).Sheets("Alap").Range("D5") = ".pdf" Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Filename, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Else
ActiveWorkbook.SaveAs Filename
End If
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Set myAttachments = OutMail.Attachments
myAttachments.Add Filename
End If
.Attachments.Add Sheets("Alap").Range("C7")
.Send 'or use .Display
Sheets(kinek).Cells(sor, 6) = Time()
End With
End If
sor = sor + 1
Wend
End Sub -
Amiens
tag
Sziasztok!
Excel-ben makrókkal küldöm ki az e-maileket.
Az alapértelmezett fiókcímemet szeretném megváltoztatni, hogy ne az én nevemben küldje el az e-maileket.
Mennyire lehet erre megoldást találni?Ami
Új hozzászólás Aktív témák
- laca223: Miért győz a kollektív meggyőződés akkor is, ha saját magát teszi tönkre?
- TCL LCD és LED TV-k
- Napelem
- Építő/felújító topik
- Telekom mobilszolgáltatások
- Hobby elektronika
- Okos Otthon / Smart Home
- Sorozatok
- XPEnology
- Amit látnod kell 80’ – 90’ évek, egész estét betöltő mozi filmjei.
- További aktív témák...
- RTX 4070 ti I Ryzen 5 7600X I 2x16gb ddr5 6000mHz
- LAST MINUTE KARÁCSONY! 2 egyforma i7 GAMER GÉP! Ingyenes SOS kiszállítás (Bp.) !!!
- Asus ROG Zephyrus G16 Intel Core Ultra 9 185H/RTX 4060/16GB DDR5/1TB SSD eladó NÁLAM A LEGOLCSÓBBAN!
- MacBook Pro M1 13 inch 8/512GB magyar bill nálam a legolcsóbban
- Fujitsu 27" B27-8 TE Full HD 1920x1080 hófehér monitor állítható magasság, PIVOT, HDMI számla + gar
- HIBÁTLAN iPhone 13 Pro 256GB Sierra Blue 1ÉV GARANCIA -Kártyafüggetlen, MS3743, 91% Akkumulátor
- Microsoft Surface Laptop 5 13,5" Fekete i7-1265U 16GB 512GB magyarbill 1 év garancia
- Apple iPhone 14 256GB, Kártyafüggetlen, 1 Év Garanciával
- GYÖNYÖRŰ iPhone 13 mini 128GB Green -1 ÉV GARANCIA - Kártyafüggetlen, MS3338
- BESZÁMÍTÁS! Gigabyte Z390 i5 9600K 16GB DDR4 512GB SSD RTX 2060 Super 8GB Rampage SHIVA ADATA 600W
Állásajánlatok
Cég: Laptopszaki Kft.
Város: Budapest
Cég: BroadBit Hungary Kft.
Város: Budakeszi


Köszönöm szépen!



