Vba

[Patrice74]

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

 

[igold]

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.

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.

 

[Peter_SSs]

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.

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?)

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

 

[Patrice74]

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.

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?)

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]

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]

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]

OK, thanks for the clarification. Try

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]

OK, thanks for the clarification. Try

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

 

[Peter_SSs]

Thanks a lot! It was a wonderful help

You're welcome. Thanks for the follow-up.