Vba

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
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
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:
Upvote 0
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:
Upvote 0
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 :-)
 
Upvote 0
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?
 
Upvote 0
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

:-)
 
Upvote 0
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
 
Upvote 0
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 :)
 
Upvote 0

Forum statistics

Threads
1,223,892
Messages
6,175,236
Members
452,621
Latest member
Laura_PinksBTHFT

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