VBA - Filter and export

[joslaz]

Hey community!

I have the following table:

ID	AB	BE	DT	TM	AA	BB	CC	DD		FF	FF
1	AB1	BE1	01.01.2018	00:00:00	1	1	1	1		1	1
2	AB1	BE2	01.01.2018	01:00:00	1	1	1	1		1	1
3	AB1	BE2	01.01.2018	02:00:00	1	1	1	1		1	1
4	AB1	BE2	01.01.2018	03:00:00	1	1	1	1		1	1
5	AB1	BE2	01.01.2018	04:00:00	1	1	1	1		1	1
6	AB2	BA1	01.01.2018	05:00:00	1	1	1	1		1	1
7	AB2	BA1	01.01.2018	06:00:00	1	1	1	1		1	1
8	AB2	BA1	01.01.2018	07:00:00	1	1	1	1		1	1
9	AB2	BA1	01.01.2018	08:00:00	1	1	1	1		1	1
10	AB2	BA1	01.01.2018	09:00:00	1	1	1	1		1	1
11	AB2	BA2	01.01.2018	10:00:00	1	1	1	1		1	1
12	AB3	BA3	01.01.2018	11:00:00	1	1	1	1		1	1
13	AB3	BA3	01.01.2018	12:00:00	1	1	1	1		1	1
14	AB3	BA3	01.01.2018	13:00:00	1	1	1	1		1	1
15	AB3	BA3	01.01.2018	14:00:00	1	1	1	1		1	1
16	AB3	BA3	01.01.2018	15:00:00	1	1	1	1		1	1
17	AB3	BA3	01.01.2018	16:00:00	1	1	1	1		1	1

<colgroup><col width="80" span="12" style="width:60pt"> </colgroup><tbody>
</tbody>

I would now like to filter by means of VBA and create the results as a new worksheet and save this sheet individually as a new file in a different folder.


The first file results from "AB1" in column 2 and "BE1" in column 3.
The second file results from "AB1" in column 2 and "BE2" in column 3.
The third file results from "AB2" in column 2 and "BA1" in column 3.
The fourth file results from "AB2" in column 2 and "BA2" in column 3.
The fifth file results from "AB3" in column 2 and "BA3" in column 3.


The folder for the first file is: "C: \ Users \ Adam "
The folder for the second file is: "C: \ Users \ Adam \ 1 "
The folder for the third file is: "C: \ Users \ Adam \ 2 "
The folder for the fourth file is: "C: \ Users \ Adam \ 3 "
The folder for the fifth file is: "C: \ Users \ Adam \ 4 "






Does anyone have any idea how this can be implemented?
With IF statements or with Case?


I've already worked with the macro recorder, but it never worked on new records.


Greeting!

 

[Norie]

This will split the data out into separate sheets, I've not added code to save them to individual workbooks as I'm not sure what filenames you would want to use.

Option Explicit

Sub SplitData()
Dim dic As Object
Dim arrIn As Variant
Dim arrOut As Variant
Dim I As Long
Dim J As Long
Dim ky As Variant

    arrIn = Sheets("Sheet1").UsedRange
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For I = LBound(arrIn) + 1 To UBound(arrIn)
        
        If Not dic.Exists(arrIn(I, 2) & arrIn(I, 3)) Then
            arrOut = Application.Transpose(Application.Index(arrIn, I))
            dic.Add arrIn(I, 2) & arrIn(I, 3), arrOut
        Else
            arrOut = dic(arrIn(I, 2) & arrIn(I, 3))
            
            ReDim Preserve arrOut(LBound(arrOut) To UBound(arrOut), LBound(arrOut, 2) To UBound(arrOut, 2) + 1)
            
            For J = LBound(arrOut) To UBound(arrOut)
                arrOut(J, UBound(arrOut, 2)) = arrIn(I, J)
            Next J
            
            dic(arrIn(I, 2) & arrIn(I, 3)) = arrOut
            
        End If
    
    Next I
    
    For Each ky In dic.keys
        Sheets.Add
        ActiveSheet.Name = ky
        arrOut = dic(ky)
        Range("A1").Resize(, UBound(arrIn, 2)).Value = Application.Index(arrIn, 1)
        With Range("A2")
            .Resize(UBound(arrOut, 2), UBound(arrOut, 1)).Value = Application.Transpose(arrOut)
            .Offset(, 4).Resize(UBound(arrOut, 2)).NumberFormat = "hh:mm"
        End With
    Next ky
    
End Sub

 

[Fluff]

Another option

Sub CopyFilter()
   Dim Ary As Variant
   Dim i As Long
   Dim Pth As String
   
   Application.ScreenUpdating = False
   Pth = "C:\Users\Adam\"
   Ary = Array("AB1", "BE1", "", "AB1", "BE2", "1\", "AB2", "BA1", "2\", "AB2", "BA2", "3\", "AB3", "BA3", "4\")
   With Sheet9
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) Step 3
         .range("A1:L1").AutoFilter 2, Ary(i)
         .range("A1:L1").AutoFilter 3, Ary(i + 1)
         Workbooks.Add (1)
         .AutoFilter.range.Copy range("A1")
         ActiveWorkbook.SaveAs Pth & Ary(i + 2) & Ary(i) & Ary(i + 1) & ".xlsx", 51
         ActiveWorkbook.Close False
      Next i
      .AutoFilterMode = False
   End With
End Sub

I've used AB1BE1 etc as the file name

 

[joslaz]

Ok, it's almost perfect!
But somehow a folder is created per file.
Is this the third element in the array?
How can I prevent this?


How can I define the array or code if I want to have a file with all "AB1" defined in column 3? (So without consideration of the other criteria?
And how do I define the array if I want to have all "AB1" in column 3 with "B2-B5" in column4.


And how can I define the path according to the following logic?


1. File: C: \ Users \ Adam \ Anton
2. File: C: \ Users \ Adam \ Max
3. File: C: \ Users \ Adam \ Karl
4. File: C: \ Users \ Adam \ Stacey
5. File: C: \ Users \ Stacey \ P

 

[Fluff]

Firstly the code I supplied does not create any new folders. If the folder does not exist you'll get an error.
Secondly I do not understand your new logic for defining folders. Please remember that we have no knowledge of what you are trying to do, we cannot see your data & have no idea of who Anton, Max etc are or how they relate to your data.
Every third value in the array is the final part of file path. try adjusting them to suit your needs.

 

[joslaz]

Ok cool thanks!

I am allready trying to get to the bottom of the code, especially with F8.
But unfortunatelly I cant figure out, how I can adjust your array to get the filter once only for column 3 total.

I am sorry about the little chaos.


Thanks at all!

 

[Fluff]

Do you mean that you want all AB1 in one workbook, regardless of what the BE value is?

 

[joslaz]

Correct.
And this with the array from above.

Something like this:?

Ary = Array("AB1", "BE1", "", "AB1", "BE2", "1", "AB2", "BA1", "2", "AB2", "BA2", "3", "AB3", "BA3", "4", "AB1", "", "5")[

Thanks a lot!!

 

[Fluff]

Ok, how about

Sub CopyFilter()
   Dim Ary As Variant
   Dim i As Long
   Dim Pth As String
   
   Application.ScreenUpdating = False
   Pth = "C:\MrExcel\Fluff\"
   Ary = Array("AB1", "", "AB1", "1\", "AB2", "2\", "AB2", "3\", "AB3", "4\")
   With Sheet9
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) Step 2
         .Range("A1:L1").AutoFilter 2, Ary(i)
         Workbooks.Add (1)
         .AutoFilter.Range.Copy Range("A1")
         ActiveWorkbook.SaveAs Pth & Ary(i + 1) & Ary(i) & ".xlsx", 51
         ActiveWorkbook.Close False
      Next i
      .AutoFilterMode = False
   End With
End Sub

PS. You need to keep the \ in the array or it will read the wrong path

 

[joslaz]

Ok cool, thanks!

I'm sorry, but I need to explain the objective a little bit more detailed.
Maybe a table will help.

Path	Table	Criteria Column3	Criteria Column4
C:\MrExcel\Fluff\AA\	1	AB1
C:\MrExcel\Fluff\AB\	2	AB1	B1
C:\MrExcel\Fluff\AC\	3	AB1	B2
C:\MrExcel\Fluff\AC\AA\	4	AB2	B1
C:\MrExcel\Fluff\AC\AB\	5	AB3	B2

<tbody>
</tbody>

Do you think, a second array will fix that issue with the first tbl?

Pth = "C:\MrExcel\Fluff"
Ary1 = Array("AB1", "AA")
Ary2 = Array("AB1", "BE1", "AB", "AB1", "BE2", "AC", "AB2", "B1", "AC\AA", "AB3", "B2", "AC\AB")

With Sheet9
If .AutoFilterMode Then .AutoFilterMode = False

For i = 0 To UBound(Ary1) Step 2
.Range("A1:L1").AutoFilter 2, Ary1(i)
Workbooks.Add (1)
.AutoFilter.Range.Copy Range("A1")
ActiveWorkbook.SaveAs Pth & Ary1(i + 1) & Ary1(i) & ".xlsx", 51
ActiveWorkbook.Close False
Next i

For i = 0 To UBound(Ary) Step 3
.range("A1:L1").AutoFilter 2, Ary(i)
.range("A1:L1").AutoFilter 3, Ary(i + 1)
Workbooks.Add (1)
.AutoFilter.range.Copy range("A1")
ActiveWorkbook.SaveAs Pth & Ary(i + 2) & Ary(i) & Ary(i + 1) & ".xlsx", 51
ActiveWorkbook.Close False
Next i