Selectie obv. criteria

[Welies]

Beste mensen,

Op bijgevoegd bestand wil ik een macro toepassen die:

1. Alle kolommen verwijderd muv de geel gemarkeerd
2. Uitvoeren van een aantal criteria (zie bijlage)
3. Op alle overgebleven kolommen een filter zet

Alvast dank!
Vincent

 

[spaarie]

Zoiets?

Sub Spaarie()
    bestand = Application.GetOpenFilename("Excel Files, *.xls; *.xlsx; *.xlsm", , "Selecteer bestand")
    If bestand = False Then
        MsgBox "U heeft geen bestand gekozen.", vbCritical, "Fout"
        Exit Sub
    End If
    
    'Workbooks.Open (bestand)
    With ActiveWorkbook.Sheets("MP")
        For Each v In .Columns("K").SpecialCells(2).Offset(1).SpecialCells(2)
            If v.Value <> "" Then v.Offset(, 1).Value = Left(v.Value, 2)
        Next
        
        For c = .UsedRange.Columns.Count To 1 Step -1
            If .Cells(1, c).Interior.Color <> RGB(255, 255, 0) Then .Columns(c).Delete xlLeft
        Next

        .UsedRange.Copy
        
        With Sheets.Add
            .Name = "TB"
            .Range("A1").PasteSpecial
            .UsedRange.AutoFilter 3, Array("PM", "TF", "TX"), xlFilterValues
        End With
    End With
    
End Sub

 

[Welies]

Beste Spaarie,

In het voorbeeldbestand werkt de macro (dat heb ik tenslotte ook gevraagd ), maar wat ik uiteindelijk wil is een stapje verder:

- Ik heb een knop met daaraan gekoppeld de betreffende macro
- Vervolgens opent de macro een verkenner scherm middels het drukken op de knop en browse ik naar het betreffenden .txt bestand (open ik deze in exel dan heeft deze de opmaak van het test.xls bestand (muv de gekleurde cellen))
- Daarna wordt de macro uitgevoerd met als resultaat de records in een nieuw tabblad, die voldoen aan de eerder genoemde criteria

Excuus voor mijn onvolledigheid.
Vincent

 

[spaarie]

Ik wist al dat het niet op het originele bestand ging werken...
Rode gedeelte is aangepast;

Sub Spaarie()
    bestand = Application.GetOpenFilename("Excel Files, *.xls; *.xlsx; *.xlsm", , "Selecteer bestand")
    If bestand = False Then
        MsgBox "U heeft geen bestand gekozen.", vbCritical, "Fout"
        Exit Sub
    End If
    Workbooks.Open (bestand)
    With ActiveWorkbook.Sheets("MP")
        For Each v In .Columns("K").SpecialCells(2).Offset(1).SpecialCells(2)
            If v.Value <> "" Then v.Offset(, 1).Value = Left(v.Value, 2)
        Next
[COLOR="#FF0000"]        For c = .UsedRange.Columns.Count To 1 Step -1
            Select Case .Cells(1, c).Value
                Case "nummer", "Prijs 2", "Eigenaar"
            Case Else
                .Columns(c).Delete xlLeft
            End Select
        Next[/COLOR]
        .UsedRange.Copy
        With [COLOR="#FF0000"]ThisWorkbook[/COLOR].Sheets.Add
            .Name = "TB"
            .Range("A1").PasteSpecial
            .UsedRange.AutoFilter 3, Array("PM", "TF", "TX"), xlFilterValues
        End With
    End With
End Sub

 

[Welies]

Dank voor je snelle reactie!
Ik krijg bij regel ".UsedRange.AutoFilter 3, Array("PM", "TF", "TX"), xlFilterValues" de volgende fout:

 

[spaarie]

Misschien toch in het stukje hieronder ThisWorkbook weghalen?

With [COLOR="#FF0000"]ThisWorkbook[/COLOR].Sheets.Add
    .Name = "TB"
    .Range("A1").PasteSpecial
    .UsedRange.AutoFilter 3, Array("PM", "TF", "TX"), xlFilterValues
End With