VBA - Filter and export

J

joslaz

Board Regular
Joined
May 24, 2018
Messages
76
Hey community!

I have the following table:


[TABLE="width: 960"]
<colgroup><col width="80" span="12" style="width:60pt"> </colgroup><tbody>[TR]
[TD="width: 80"]ID[/TD]
[TD="width: 80"]AB[/TD]
[TD="width: 80"]BE[/TD]
[TD="width: 80"]DT[/TD]
[TD="width: 80"]TM[/TD]
[TD="width: 80"]AA[/TD]
[TD="width: 80"]BB[/TD]
[TD="width: 80"]CC[/TD]
[TD="width: 80"]DD[/TD]
[TD="width: 80"][/TD]
[TD="width: 80"]FF[/TD]
[TD="width: 80"]FF[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]AB1[/TD]
[TD]BE1[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]00:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD]AB1[/TD]
[TD]BE2[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]01:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD]AB1[/TD]
[TD]BE2[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]02:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[TD]AB1[/TD]
[TD]BE2[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]03:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]AB1[/TD]
[TD]BE2[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]04:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]AB2[/TD]
[TD]BA1[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]05:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]AB2[/TD]
[TD]BA1[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]06:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]8[/TD]
[TD]AB2[/TD]
[TD]BA1[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]07:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[TD]AB2[/TD]
[TD]BA1[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]08:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[TD]AB2[/TD]
[TD]BA1[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]09:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]AB2[/TD]
[TD]BA2[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]10:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]AB3[/TD]
[TD]BA3[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]11:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]13[/TD]
[TD]AB3[/TD]
[TD]BA3[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]12:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]14[/TD]
[TD]AB3[/TD]
[TD]BA3[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]13:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]15[/TD]
[TD]AB3[/TD]
[TD]BA3[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]14:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]16[/TD]
[TD]AB3[/TD]
[TD]BA3[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]15:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]17[/TD]
[TD]AB3[/TD]
[TD]BA3[/TD]
[TD="class: xl63, align: right"]01.01.2018[/TD]
[TD="class: xl64, align: right"]16:00:00[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
</tbody>[/TABLE]

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!
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
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.
Code: 
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
 
Upvote 0
Another option
Code: 
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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!
 
Upvote 0
Do you mean that you want all AB1 in one workbook, regardless of what the BE value is?
 
Upvote 0
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")[
Click to expand...


Thanks a lot!!
 
Upvote 0
Ok, how about
Code: 
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
 
Upvote 0
Ok cool, thanks!

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

[TABLE="width: 500"]
<tbody>[TR]
[TD]Path[/TD]
[TD]Table[/TD]
[TD]Criteria Column3[/TD]
[TD]Criteria Column4[/TD]
[/TR]
[TR]
[TD]C:\MrExcel\Fluff\AA\[/TD]
[TD]1[/TD]
[TD]AB1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]C:\MrExcel\Fluff\AB\[/TD]
[TD]2[/TD]
[TD]AB1[/TD]
[TD]B1[/TD]
[/TR]
[TR]
[TD]C:\MrExcel\Fluff\AC\[/TD]
[TD]3[/TD]
[TD]AB1[/TD]
[TD]B2[/TD]
[/TR]
[TR]
[TD]C:\MrExcel\Fluff\AC\AA\[/TD]
[TD]4[/TD]
[TD]AB2[/TD]
[TD]B1[/TD]
[/TR]
[TR]
[TD]C:\MrExcel\Fluff\AC\AB\[/TD]
[TD]5[/TD]
[TD]AB3[/TD]
[TD]B2[/TD]
[/TR]
</tbody>[/TABLE]


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
Click to expand...
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Finding Numbers from a Column Using Target Numbers
2
Replies
11
Views
414
Cubist
Cubist
M
  • Solved
Split single cell value in 2 columns.
Replies
7
Views
359
Fluff
Fluff
K
  • Solved
Formula to match two columns and get a result from third one
Replies
5
Views
334
Fluff
Fluff
T
  • Solved
Looking for VBA Code to Conditionally Format Time Tracker on Entry
Replies
3
Views
177
Tara_A_Data
T
S
  • Solved
Date time to Date conversion
Replies
4
Views
512
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top