Patrice74

New Member
Joined
Dec 3, 2018
Messages
10
Hi

I hope somebody can help me. I need to repeat an action many time. I put a filter with initial from a list and copy the data in a sheet and save it.

ActiveSheet.Range(A1:T788).Autofilter Field:=8, Criterial:"TFB"
Range(A1:U788).select
Selection.copy
workbooks.add
activesheet.paste

How can choose criterial from a list

TFB
FXH
CG
PAM
KLP

etc

Thanks in advance
Patice
 

Some videos you may like

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,493
Office Version
365, 2010
Platform
Windows
Hi,

Something like this would take your list from Sheet2, filter your ActiveSheet, and copy the filtered data to a new workbook. You did not say what you wanted to do with the workbooks after they are created so when the Macro completes you will be left with a number of open workbooks that you will have to save manually. That process could be in the macro if you provided more information as far as the naming convention and location.

Code:
Sub SaveToNewBook()

    Dim i As Long, lRow As Long
    Dim filt As String
    Dim rng As Range
    Dim wb  As Workbook
    Dim tWb As Workbook: Set tWb = ThisWorkbook
    
    lRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
'Flilter ActiveSheet with data froms sheet2
    For i = 1 To lRow
        filt = Worksheets("Sheet2").Cells(i, 1)
        ActiveSheet.Range("A1:U788").AutoFilter field:=8, Criteria1:=filt, Operator:=xlFilterValues
        Set rng = ActiveSheet.AutoFilter.Range
        rng.Copy
        Set wb = Workbooks.Add
        wb.ActiveSheet.Paste
        tWb.Activate
        ActiveSheet.AutoFilterMode = False
        Application.CutCopyMode = False
    Next
    
End Sub
I hope this helps.
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
44,787
Office Version
365
Platform
Windows
I've taken a guess that the range A1:T788 contains all the data on the worksheet. If that is not the case then you can ignore the rest of this post. :cool:

Otherwise, if my guess is correct, here is a slightly different approach (which also leaves you with a number of open, unsaved new workbooks).

I have assumed that the list of criteria is in "Sheet2" in the range (A2:A?)

Rich (BB code):
Sub ExtractData()
  Dim wsAct As Worksheet
  Dim vals As Variant, itm As Variant
  
  Set wsAct = ActiveSheet
  vals = Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Value
  Application.ScreenUpdating = False
  For Each itm In vals
    wsAct.Copy
    With ActiveSheet.UsedRange
      .AutoFilter Field:=8, Criteria1:="<>" & itm
      .Offset(1).EntireRow.Delete
    End With
    ActiveSheet.AutoFilterMode = False
  Next itm
  Application.ScreenUpdating = True
End Sub
 
Last edited:

Patrice74

New Member
Joined
Dec 3, 2018
Messages
10
I've taken a guess that the range A1:T788 contains all the data on the worksheet. If that is not the case then you can ignore the rest of this post. :cool:

Otherwise, if my guess is correct, here is a slightly different approach (which also leaves you with a number of open, unsaved new workbooks).

I have assumed that the list of criteria is in "Sheet2" in the range (A2:A?)

Rich (BB code):
Sub ExtractData()
  Dim wsAct As Worksheet
  Dim vals As Variant, itm As Variant
  
  Set wsAct = ActiveSheet
  vals = Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Value
  Application.ScreenUpdating = False
  For Each itm In vals
    wsAct.Copy
    With ActiveSheet.UsedRange
      .AutoFilter Field:=8, Criteria1:="<>" & itm
      .Offset(1).EntireRow.Delete
    End With
    ActiveSheet.AutoFilterMode = False
  Next itm
  Application.ScreenUpdating = True
End Sub
Hi,
Thanks a lot! It works perfeclty! I forgot to ask how I save the file with the name of column B
Eks:
HJA 433
JUH 715
PKK 582

that's mean that if the filter is HJA the file should be saved as: G:/433.xls
Can you help me?
Thanks :)
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
44,787
Office Version
365
Platform
Windows
that's mean that if the filter is HJA the file should be saved as: G:/433.xls
Does that mean that when filtered for HJA, every visible row contains the same value (eg 433) in column B?
 

Patrice74

New Member
Joined
Dec 3, 2018
Messages
10
Does that mean that when filtered for HJA, every visible row contains the same value (eg 433) in column B?
In sheets2 there is 2 columns. A = Initial, column B = number

When column H is filtrered with A2 then the file have to be saved with the value from column B

:)
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
44,787
Office Version
365
Platform
Windows
OK, thanks for the clarification. Try

Rich (BB code):
Sub ExtractData_v2()
  Dim wsAct As Worksheet
  Dim vals As Variant
  Dim i As Long
  
  Set wsAct = ActiveSheet
  vals = Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp)).Value
  Application.ScreenUpdating = False
  For i = 1 To UBound(vals)
    wsAct.Copy
    With ActiveSheet.UsedRange
      .AutoFilter Field:=8, Criteria1:="<>" & vals(i, 1)
      .Offset(1).EntireRow.Delete
    End With
    ActiveSheet.AutoFilterMode = False
    ActiveWorkbook.SaveAs Filename:="G:\" & vals(i, 2) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
  Next i
  Application.ScreenUpdating = True
End Sub
 

Patrice74

New Member
Joined
Dec 3, 2018
Messages
10
OK, thanks for the clarification. Try

Rich (BB code):
Sub ExtractData_v2()
  Dim wsAct As Worksheet
  Dim vals As Variant
  Dim i As Long
  
  Set wsAct = ActiveSheet
  vals = Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp)).Value
  Application.ScreenUpdating = False
  For i = 1 To UBound(vals)
    wsAct.Copy
    With ActiveSheet.UsedRange
      .AutoFilter Field:=8, Criteria1:="<>" & vals(i, 1)
      .Offset(1).EntireRow.Delete
    End With
    ActiveSheet.AutoFilterMode = False
    ActiveWorkbook.SaveAs Filename:="G:\" & vals(i, 2) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
  Next i
  Application.ScreenUpdating = True
End Sub
Thanks a lot! It was a wonderful help :)
 

Watch MrExcel Video

Forum statistics

Threads
1,100,193
Messages
5,473,071
Members
406,845
Latest member
JohnR123

This Week's Hot Topics

Top