2. Fórumok
  3. Szoftverfejlesztés
  4. Visual Basic

Új hozzászólás Aktív témák

  • #2720 Amiens tag sztanozs #2719
    Új Válasz #2720
    Új hozzászólás
    Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra
    Privát üzenet küldése

    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