Unieke filtering in VBA code aanpassen

[TMD]

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?

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

 

[JeanPaul28]

Als je een bestand er bij voegt heb je misschien meer succes

 

[TMD]

Ik was in de veronderstelling dat de bijlage erbij zat. Nu in ieder geval wel.

 

[JeanPaul28]

Test deze macro eens uit, sheet controle stond er niet tussen heb dan ook niet kunnen testen
Alles tussen astrik heb ik bijgevoegd

Sub Bepaal_Unieke_selectie()
Sheets("Hulpsheet").Range("A:C").ClearContents
''***************************

For Each cl In Sheets("Controle").Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If cl.Offset(0, 10).Value = "Nee" Then

Set MyRange = Cells(cl.Row, 1).Resize(1, 3)
sq = ""
For Each cell In [MyRange]
sq = sq & cell.Value & "|"
Next
End If

With Sheets("Hulpsheet")
.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(1, 3).Value = Split(sq, "|")
sq = ""
End With
Next
'*****************************
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