VBA - Tabel Filteren - Data Kopieren - Resultaat Exporteren

[SjofaaSj]

[zie ook voorbeeldbestand in bijlage]

1. Maandelijks krijg ik gegevens door (groene kolommen) waar ik parameters moet aanhangen (oranje kolommen).
2. Per Company moeten de parameters gefilterd worden om ze naar een aparte tabblad te kopiëren (blauwe sheets).
3. Waarna ik van elk van die sheets een .csv bestand moet maken

Moeilijkheden:
- Met de controlekolom wordt nagekeken of de parameters bestaan ; enkel de lijnen met 0 mogen worden meegenomen.
- Het aantal verschillende companies kan variëren.

In het voorbeeldbestand heb ik het vrij eenvoudig gehouden, maar in realiteit zijn er aanzienlijk meer rijen en companies.
Kan iemand me een manier aan de hand doen om dit te automatiseren, waarbij ik volgende logica in gedachten had:

A. Filter1 = alle lijnen met 0 in de check-kolom van tabel "T_DATA"
B. Filter2 = Company
C. Copy van de gefilterde gegevens in de oranje kolommen
D. Nieuw tabblad waar deze gegevens worden geplakt en hernoemen volgend de Company-naam
E. Herhalen van stappen B tot D tot alle verschillende companies behandeld zijn
F. Export van alle nieuwe tabs als CSV bestand
​

Alvast bedankt voor de hulp

 

[SjofaaSj]

100 views maar niet 1 reply

Heb intussen de data kunnen filteren met deze code

Sub Data_FilterSet()
    Dim myRng As Range
    Dim myTbl As Excel.ListObject
    Dim myColFirst As Integer
    Dim myColNr As Integer
    Dim myColName As String
    Dim myCnt
    Dim CntRow As Long
    Dim myFilter As String
'PRM
    myFilter = "HQ"
    myColName = "X_Company" 'name of 1st column
    Set myTbl = ActiveSheet.ListObjects(1)
    CntRow = myTbl.DataBodyRange.Columns(1).Rows.Count 'all rows
    'check if first column of table is first column of sheet
    myColFirst = myTbl.ListColumns(1).Range.Column
    If myColFirst = 1 Then
        myColNr = myTbl.ListColumns(myColName).Range.Column
    Else
        myColNr = myTbl.ListColumns(myColName).Range.Column - myColFirst + 1
    End If
    
'RUN
    myTbl.Range.AutoFilter Field:=myColNr, Criteria1:=myFilter, Operator:=xlAnd
    'count
    On Error Resume Next
    myCnt = myTbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible).Count 'count filtered rows
    If myCnt = 0 Then
        myTbl.Range.AutoFilter Field:=myColNr
        MsgBox "PROCEDURE CONFIRMATION" & vbLf & vbLf & _
               "Worksheet '" & ActiveSheet.Name & "' : " & vbLf & _
               "No Filtered Records", _
               vbExclamation + vbOKOnly, "JDW - FILTER SET"
        Exit Sub
    End If
End Sub

Maar heb er geen flauw idee van hoe ik de unieke waarden uit de kolom "X_Company"
in een loop kan steken en doorgeven aan deze query om als filtercriterium te gebruiken.

 

[cow18]

Sub Data_FilterSet()
    Dim myRng  As Range
    Dim myTbl  As Excel.ListObject
    Dim myColFirst As Integer
    Dim myColNr As Integer
    Dim myColName As String
    Dim myCnt
    Dim CntRow As Long
    Dim myFilter As String
    'PRM
    myFilter = "HQ"
    myColName = "X_Company"                                          'name of 1st column
    Set myTbl = ActiveSheet.ListObjects(1)
    CntRow = myTbl.DataBodyRange.Columns(1).Rows.Count               'all rows
    'check if first column of table is first column of sheet
    myColFirst = myTbl.ListColumns(1).Range.Column
    If myColFirst = 1 Then
        myColNr = myTbl.ListColumns(myColName).Range.Column
    Else
        myColNr = myTbl.ListColumns(myColName).Range.Column - myColFirst + 1
    End If

    'RUN
    sn = myTbl.ListColumns(myColName).Range
    With CreateObject("scripting.dictionary")
        For Each it In sn
            .Item(it) = .Item(it) + 1
        Next
        sn = .Keys
    End With

    For i = 1 To UBound(sn)
        myTbl.Range.AutoFilter Field:=myColNr, Criteria1:=sn(i), Operator:=xlAnd
        'count
        On Error Resume Next
        myCnt = myTbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible).Count    'count filtered rows
        If myCnt = 0 Then
            myTbl.Range.AutoFilter Field:=myColNr
            MsgBox "PROCEDURE CONFIRMATION" & vbLf & vbLf & _
                   "Worksheet '" & ActiveSheet.Name & "' : " & vbLf & _
                   "No Filtered Records", _
                   vbExclamation + vbOKOnly, "JDW - FILTER SET"
            Exit Sub
        End If
    Next
End Sub

 

[snb]

Ik hoop dat het je duidelijk is, dat je geen Excel vraag hebt gesteld.
Je wil iets automatiseren, maar hebt in je werkboek geen enkele code staan.
Bovendien had je je vraag dan beter in het VBA subforum kunnen stellen.

Je formuleert wat de code zou moeten doen en daar laat je het bij.
Dan wek je de indruk dat je het forum als gratis automatiseringsbedrijf wil inschakelen.
Geen wonder dat velen daar geen trek in hebben, want daarvoor is het forum ook niet bedoeld.

Zonder de aanmaak van extra bladen:

Sub M_snb()
  Sheet1.ListObjects("T_User").Range.Columns(2).AdvancedFilter 2, , Sheet1.Cells(1, 13), -1
  sn = Sheet1.Cells(1, 13).CurrentRegion
  
  For j = 2 To UBound(sn)
     With Sheet2.ListObjects(1).Range
         .AutoFilter 6, sn(j, 1)
         .Offset(, 5).Resize(, 11).Copy

         With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
           .GetFromClipboard
           CreateObject("scripting.filesystemobject").createtextfile("G:\OF\" & sn(j, 1) & ".csv").write .GetText
        End With

        .AutoFilter
    End With
 Next
End Sub

 

[SjofaaSj]

@cow18

grote dankuwel, ik ben gisteren met jouw code aan de slag gegaan
en het was de voorzet die ik nodig had om te bereiken wat ik wou
zie bijlage voor het eindresultaat
​

@snb

Ik pleit schuldig aan het feit dat het wellicht beter onder VBA dan onder excel thuis hoort, maar bestempel dit forum liever als gratis en nuttige helpdesk dan als automatiseringsforum.

Zoals ik al zei wist ik totaal niet hoe te beginnen dus code kón ik er in eerste instantie niet bijzetten, maar om tijd te winnen, heb ik de vraag gepost en ben zelf aan de slag gegaan
om uit te vissen hoe gegevens naar een nieuwe sheet te kopiëren (die code heb ik nadien toegevoegd) en deze sheets uiteindelijk naar csv te exporteren ; dat leek me de meest efficiënte manier.

Het gaat allemaal niet zo snel als sommige anderen uit hun mouw kunnen schudden en ongetwijfeld zijn er kortere manieren om het einddoel te bereiken, maar dat is een leerproces.
En net zoals ik vroeger ook al heb gedaan, post ik de finale versie hier ook op het forum ; anderen kunnen hier ook wat aan hebben, zo is het een win-win, toch?


​