- Nem indul és mi a baja a gépemnek topik
- Iszonyatos mennyiségű hulladékkal járhat a Windows 10 terméktámogatásának vége
- Bambu Lab 3D nyomtatók
- Azonnali fotós kérdések órája
- Milyen notebookot vegyek?
- OLED TV topic
- Fujifilm X
- AMD Ryzen 9 / 7 / 5 7***(X) "Zen 4" (AM5)
- Azonnali VGA-s kérdések órája
- Házimozi belépő szinten
Új hozzászólás Aktív témák
-
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
Új hozzászólás Aktív témák
- Audi, Cupra, Seat, Skoda, Volkswagen topik
- Linux kezdőknek
- Nem indul és mi a baja a gépemnek topik
- Samsung Galaxy Watch7 - kötelező kör
- Iszonyatos mennyiségű hulladékkal járhat a Windows 10 terméktámogatásának vége
- Bambu Lab 3D nyomtatók
- Azonnali fotós kérdések órája
- Körvonalazódnak az S26 Edge kamerarészletei
- Építő/felújító topik
- Háztartási gépek
- További aktív témák...
- Lenovo ThinkPad P14s/14 FHD(1920x1080)/i7-1165G7/32GB/512GB SSD/Nvidia T500(4GB GDDR6)
- iPhone 13 Midnight-128Gb-90% akku-2026.10.05. garancia
- MacBook Pro Retina 14" 8C / 14C / 16 GB / 512 SSD / Magyar / Garancia
- FULL CTO 14" MacBook Pro M2 MAX / 12C CPU / 30C GPU / 32 GB RAM / 1TB SSD / Garancia
- AKCIÓ - 2023 MacBook Pro 14" M3 CHIP / 16GB RAM / 512 SSD / Garancia
- Telefon felvásárlás!! Samsung Galaxy A22/Samsung Galaxy A23/Samsung Galaxy A25/Samsung Galaxy A05s
- ÁRGARANCIA!Épített KomPhone Ryzen 5 4500 16/32/64GB RAM RX 6600 8GB GAMER PC termékbeszámítással
- ÁRGARANCIA!Épített KomPhone i5 10600KF 16/32/64GB RAM RTX 3060 12GB GAMER PC termékbeszámítással
- HPE Aruba PoE+ L3 switch raktárról azonnal elérhető!
- Bomba ár! Dell Latitude E7250 - i5-5GEN I 8GB I 256SSD I 12,5" HD I HDMI I Cam I W10 I Garancia!
Állásajánlatok
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest