Hallo,
Ik heb onderstaande code gemaakt en deze werkt perfect. Echter gaat hij alle entries af die ik heb ingegeven achter 'For X = 2 To 100' terwijl het er soms 92 en soms 110. Wanneer het er nu 92 zijn dan maakt het systeem 8 lege mailtjes, niet het grootste probleem in de wereld maar wel onhandig. Is er een manier om dit dynamisch te maken zodat hij altijd de hoeveelheid entries pakt die in het bestand staan?
Ik heb onderstaande code gemaakt en deze werkt perfect. Echter gaat hij alle entries af die ik heb ingegeven achter 'For X = 2 To 100' terwijl het er soms 92 en soms 110. Wanneer het er nu 92 zijn dan maakt het systeem 8 lege mailtjes, niet het grootste probleem in de wereld maar wel onhandig. Is er een manier om dit dynamisch te maken zodat hij altijd de hoeveelheid entries pakt die in het bestand staan?
Code:
Sub ORG_Generate_per_dept()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
AWBN = ActiveWorkbook.Name
Sheets("Hulpsheet").Select
DBL = Sheets("Hulpsheet").Cells(Rows.Count, "A").End(xlUp).Row
For X = 2 To 100
STORENAME = Sheets("Hulpsheet").Cells(X, 2)
STORE = Application.IfError(Application.VLookup(STORENAME, Sheets("Stores").Range("A:B"), 2, 0), "")
DEPTNAME = Sheets("Hulpsheet").Cells(X, 3)
DEPT = Application.IfError(Application.VLookup(DEPTNAME, Sheets("Stores").Range("D:E"), 2, 0), "")
Sheets.Add.Name = STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate)
Sheets("sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:=STORENAME
Selection.AutoFilter Field:=2, Criteria1:=DEPTNAME
Sheets("sheet1").Range("A:O").Select
Selection.Copy Destination:=Sheets(STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate)).Range("A1")
Sheets(STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate)).Select
Sheets(STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate)).Copy
ActiveWorkbook.SaveAs Filename:= _
"H:\" & STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate) & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Windows(STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate) & ".xlsx").Close , savechanges:=False
Windows(AWBN).Activate
Sheets(STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate)).Delete
NTFind = Sheets("Email").Cells(Rows.Count, "A").End(xlUp).Row
Y = 2
Do While Y <= NTFind
If Sheets("Email").Cells(Y, 2) = STORENAME And Sheets("Email").Cells(Y, 1) = DEPTNAME Then
MAILNAME = Sheets("Email").Cells(Y, 1)
MAILADRESS = Sheets("Email").Cells(Y, 5)
End If
Y = Y + 1
Loop
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = MAILADRESS
.Subject = " & STORE & " " & DEPT
.HTMLBody = "<HTML><BODY>Test.</BODY></HTML>"
.Attachments.Add ("H:\" & STORE & " " & DEPT & " " & FormatDateTime(Date, vbShortDate) & ".xlsx")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Sheets("sheet1").Select
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Next
End Sub
