Bekijk bijlage Controle standaard Test V1.0.xlsm
Hallo,
Ik gebruik onderstaande code en deze werkt perfect. Door een kleine verandering in het bestand wil ik nu een aanpassing doen op deze code maar ik kom er zelf niet uit. De toevoeging is in Kolom K, hierin staat ja of nee wat correspondeert met de correctheid van de overige kolommen. Ik wil in de code graag toevoegen dat alleen de waardes met Nee in kolom K meegenomen worden in het mailen en bij het opslaan van de bijlage.
Is dit mogelijk?
Hallo,
Ik gebruik onderstaande code en deze werkt perfect. Door een kleine verandering in het bestand wil ik nu een aanpassing doen op deze code maar ik kom er zelf niet uit. De toevoeging is in Kolom K, hierin staat ja of nee wat correspondeert met de correctheid van de overige kolommen. Ik wil in de code graag toevoegen dat alleen de waardes met Nee in kolom K meegenomen worden in het mailen en bij het opslaan van de bijlage.
Is dit mogelijk?
Code:
Sub Run_Controle()
Debug.Print Now()
Call Bepaal_Unieke_selectie
Call ORG_Generate_per_dept
Debug.Print Now()
End Sub
Sub Bepaal_Unieke_selectie()
'Bepaal de unieke filtering
Sheets("Hulpsheet").Range("A:C").ClearContents
ENDLIST = Sheets("controle").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("controle").Range("A1:C" & ENDLIST).Copy Destination:=Sheets("Hulpsheet").Range("B1")
Sheets("Hulpsheet").Range("A1").Formula = "=B1 & C1"
Sheets("Hulpsheet").Range("A1").Copy Destination:=Sheets("Hulpsheet").Range("A2:A" & ENDLIST)
Sheets("Hulpsheet").Range("A1:C" & ENDLIST).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
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 DBL
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("controle").Select
Selection.AutoFilter Field:=1, Criteria1:=STORENAME
Selection.AutoFilter Field:=2, Criteria1:=DEPTNAME
Sheets("controle").Range("A:L").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:\Nieuw\" & 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 '(als je kolomkoppen gebruikt)
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 = "Controle" & STORE & " " & DEPT
.Body =
.Attachments.Add ("H:\Nieuw\" & 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("controle").Select
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Next
End Sub
Laatst bewerkt: