VBA to extract data from a sheet to new workbok

A

agrwlnishant

New Member
Joined
Sep 9, 2018
Messages
1
Excel 2007

Voucher NumberDateParty NameItem NameItem GroupItem DescriptionMRPItem HSNItem GSTAcutal QuantityRateUnitDiscountDiscount AmountAmount
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 150g Wafer Biscuit - Chocolate @75Harveys - Silverstar Food 751905181247.67Pcs0 572.04
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 150g Wafer Biscuit - Hazelnut @75Harveys - Silverstar Food 751905181247.67Pcs0 572.04
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 150g Wafer Biscuit - Orange @75Harveys - Silverstar Food 751905181247.67Pcs0 572.04
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 150g Wafer Biscuit - Strawberry @75Harveys - Silverstar Food 751905181247.67Pcs0 572.04
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 150g Wafer Biscuit - Vanilla @75Harveys - Silverstar Food 751905181247.67Pcs0 572.04
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Almonds @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Banana @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Blue @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Raspberry @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Red @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Rose @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Strawberry @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Vanilla @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
001/S/18-19/PN03-09-2018Camp - Dorabjee & Co. Pvt. Ltd.SF Harveys 28ml Essence - Yellow @59Harveys - Silverstar Food 593301181237.50Pcs0 450.00
002/S/18-19/PN03-09-2018Super Market Grocery Su Pvt. LtdWhistle 60g Multigrain Puffs - Cheese @60Whistle 602106121237.50Pcs0 450.00
002/S/18-19/PN03-09-2018Super Market Grocery Su Pvt. LtdWhistle 60g Multigrain Puffs - Masala @60Whistle 602106121237.50Pcs0 450.00
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 60g Cheesy Makhana (No Onion Garlic) @100Whistle 1002106121858.04Pcs0 1044.72
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 60g Multigrain Puffs - BBQ @60Whistle 602106122434.82Pcs0 835.68
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 60g Multigrain Puffs - Cheese @60Whistle 602106122434.82Pcs0 835.68
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 60g Multigrain Puffs - Masala @60Whistle 602106122134.82Pcs0 731.22
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 60g Peppery Makhana @100Whistle 1002106121958.04Pcs0 1102.76
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 60g Sunshine Makhana @100Whistle 1002106122458.04Pcs0 1392.96
003/S/18-19/PN03-09-2018Viman Nagar - Dorabjee & Co. Pvt. Ltd.Whistle 75g Chana Chor - Chilli Lime @40Whistle 402106122423.21Pcs0 557.04
004/S/18-19/PN04-09-2018Kothrud - M/s N.V. CashewSF Harveys 150g Wafer Biscuit - Chocolate @75Harveys - Silverstar Food 75190518449.58Pcs0 198.32
004/S/18-19/PN04-09-2018Kothrud - M/s N.V. CashewSF Harveys 150g Wafer Biscuit - Hazelnut @75Harveys - Silverstar Food 75190518449.58Pcs0 198.32
004/S/18-19/PN04-09-2018Kothrud - M/s N.V. CashewSF Harveys 150g Wafer Biscuit - Orange @75Harveys - Silverstar Food 75190518449.58Pcs0 198.32
004/S/18-19/PN04-09-2018Kothrud - M/s N.V. CashewSF Harveys 150g Wafer Biscuit - Strawberry @75Harveys - Silverstar Food 75190518449.58Pcs0 198.32
004/S/18-19/PN04-09-2018Kothrud - M/s N.V. CashewSF Harveys 150g Wafer Biscuit - Vanilla @75Harveys - Silverstar Food 75190518449.58Pcs0 198.32
005/S/18-19/PN04-09-2018Kothrud - Joglekar FoodsSF Harveys 150g Wafer Biscuit - Hazelnut @75Harveys - Silverstar Food 75190518349.58Pcs0 148.74
005/S/18-19/PN04-09-2018Kothrud - Joglekar FoodsSF Harveys 150g Wafer Biscuit - Vanilla @75Harveys - Silverstar Food 75190518349.58Pcs0 148.74
005/S/18-19/PN04-09-2018Kothrud - Joglekar FoodsSF Harveys 28ml Essence - Banana @59Harveys - Silverstar Food 59330118339.00Pcs0 117.00
005/S/18-19/PN04-09-2018Kothrud - Joglekar FoodsSF Harveys 28ml Essence - Raspberry @59Harveys - Silverstar Food 59330118339.00Pcs0 117.00
006/S/18-19/PN04-09-2018Kothrud - S.P. CaterersBA Delicious 1000g Chicken Cheese Garlic Fingers @468Delicious - Baramati Agro 4681602122330.94Pcs0 661.88
006/S/18-19/PN04-09-2018Kothrud - S.P. CaterersBA Delicious 1000g Chicken Nuggets (Classic) @420Delicious - Baramati Agro 4201602122281.25Pcs0 562.50
006/S/18-19/PN04-09-2018Kothrud - S.P. CaterersBA Delicious 1000g Chicken Pop Ons (Popcorn) @417Delicious - Baramati Agro 4171602122279.24Pcs0 558.48
007/S/18-19/PN04-09-2018Shivane - Mananjali SalesBA Delicious 250g Chicken Pop Ons (Popcorn) @130Delicious - Baramati Agro 1301602121092.86Pcs0 928.60
007/S/18-19/PN04-09-2018Shivane - Mananjali SalesBA Delicious 300g Chicken Rings @155Delicious - Baramati Agro 1551602128110.71Pcs0 885.68
007/S/18-19/PN04-09-2018Shivane - Mananjali SalesBA Delicious 500g Chicken Nuggets (Classic) @255Delicious - Baramati Agro 25516021210182.14Pcs0 1821.40
008/S/18-19/PN05-09-2018Cash InvoiceMC Cocon 1500g Jelly - Lychee (100 Cups) @300Cocon - Magnum Chocolatier 30017049010126169.64Pcs0 1017.84
008/S/18-19/PN05-09-2018Cash InvoiceMC Cocon 240g Pudding - Mixed (3 Cups) @60Cocon - Magnum Chocolatier 6017049090123241.79Pcs0 1337.28
008/S/18-19/PN05-09-2018Cash InvoiceMC Cocon 708g Pudding - Mixed (6 cups) @150Cocon - Magnum Chocolatier 150170490901216104.46Pcs0 1671.36
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsMC Win2 70g Magic Crunch - Chocolate @50Win2 - Magnum Chocolatier 501905909018233.05Pcs0 66.10
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsMC win2 70g Magic Crunch - Strawberry @50Win2 - Magnum Chocolatier 501905909018233.05Pcs0 66.10
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsMC win2 70g Magic Crunch - Vanilla @50Win2 - Magnum Chocolatier 501905909018233.05Pcs0 66.10
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 110g Wafer Pouch - Chocolate @99Harveys - Silverstar Food 99190518265.44Pcs0 130.88
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 110g Wafer Pouch - Orange @99Harveys - Silverstar Food 99190518265.44Pcs0 130.88
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 110g Wafer Pouch - Strawberry @99Harveys - Silverstar Food 99190518265.44Pcs0 130.88
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 110g Wafer Pouch - Vanilla @99Harveys - Silverstar Food 99190518265.44Pcs0 130.88
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 150g Wafer Biscuit - Chocolate @75Harveys - Silverstar Food 75190518549.58Pcs0 247.90
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 150g Wafer Biscuit - Hazelnut @75Harveys - Silverstar Food 75190518549.58Pcs0 247.90
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 150g Wafer Biscuit - Orange @75Harveys - Silverstar Food 75190518549.58Pcs0 247.90
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 150g Wafer Biscuit - Strawberry @75Harveys - Silverstar Food 75190518549.58Pcs0 247.90
009/S/18-19/PN05-09-2018Salisbury Park - Tara Mulchand SweetsSF Harveys 150g Wafer Biscuit - Vanilla @75Harveys - Silverstar Food 75190518549.58Pcs0 247.90
010/S/18-19/PN05-09-2018Kondhwa - FoodieOmay 115g Beaten Brown Rice - Desi Mix @120Omay 120200812285.71Pcs0 171.42
010/S/18-19/PN05-09-2018Kondhwa - FoodieOmay 140g Beaten Moong @90Omay 90200812264.29Pcs0 128.58
010/S/18-19/PN05-09-2018Kondhwa - FoodieOmay 160g Solid Soyabean @90Omay 90200812264.29Pcs0 128.58
010/S/18-19/PN05-09-2018Kondhwa - FoodieOmay 165g Oats & Moong Mix @175Omay 1752008122125.00Pcs0 250.00
011/S/18-19/PN05-09-2018MG Road - The Taste FactorySF Kings Coffee 280ml Cold Coffee - Latte @139Kings Coffee - Silverstar Food 139220212496.80Pcs0 387.20
011/S/18-19/PN05-09-2018MG Road - The Taste FactorySF Kings Coffee 280ml Cold Coffee - Mocha @139Kings Coffee - Silverstar Food 139220212496.80Pcs0 387.20

<colgroup><col><col><col><col><col><col><col><col><col span="2"><col><col><col><col><col></colgroup><tbody>
</tbody>


This is a sample data of my report.
In this, I have to usually put a filter in "Item Group" Column with Contains = "Whichever name after the = sign"
Then I copy the data in to a new file along with the heading row and save it.

Is there any way to make a VBA wherein it asks me the "Contains =" Filter every time I run it and then proceeds to filter, copy and paste in to a new file (with all the existing formatting) for me to manually save?

Would be of great help as I generally take 1.5 to 2 hrs with doing it my way.
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Sort by date Sort by votes
Does this do what you want...

Code: 
Sub FilterSave()


    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim arr, hdr, strSearch
    Dim x As Long, lRow As Long, i  As Long
    
    Application.ScreenUpdating = False
    hdr = Range("A1:O1")
    lRow = Cells(Rows.Count, 5).End(xlUp).Row
    arr = Range("E2:E" & lRow)
    With CreateObject("Scripting.Dictionary")
    For x = LBound(arr) To UBound(arr)
        If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
    Next
    strSearch = .KEYS
    End With
    For i = LBound(strSearch) To UBound(strSearch)
        With ws
            .AutoFilterMode = False
                With .Range("E1:E" & lRow)
                    .AutoFilter field:=1, Criteria1:=strSearch(i)
                    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                End With
            Workbooks.Add
            Range("A2").PasteSpecial Paste:=xlPasteAll
            Range("A1:O1") = hdr
            Range("A1").Select
            Dim workbook_Name As Variant
            workbook_Name = Application.GetSaveAsFilename
            If workbook_Name <> False Then
                ActiveWorkbook.SaveAs Filename:=workbook_Name
            End If
            ActiveWorkbook.Close
            .AutoFilterMode = False
        End With
    Next
    Application.ScreenUpdating = True
    
End Sub
 
Last edited:
Upvote 0
.
agrwlnishant & igold

Here is an automated version of igold's macro.

The user needs to double-click the "Item Group Name" (rows 2 till end of rows) desired. Example : If you are wanting to save all of the "Omay" rows to a separate workbook,
double-click on the "Omay" in Col E / Item Group. The macros will automatically create a workbook saved with the name "Omay", copy all the rows pertaining to "Omay" in Col E,
close the newly saved workbook and return the user to Sheet 1 in the "Filter Visible Rows" workbook.

You can change the name of the workbook ("Filter Visible Rows") to anything you like. If you want the saved workbooks containing the "Item Group" rows to be named something else,
these macros won't work. It will need editing.


Paste this macro into the Sheet 1 module :

Code: 
Option Explicit


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim rngTable As Range
    Dim rngData As Range
    Dim iColumn As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Set rngTable = Range("mydata")
    With rngTable
        Set rngData = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
        If Not Application.Intersect(ActiveCell, rngData.Cells) Is Nothing Then
            iColumn = ActiveCell.Column
            If ActiveSheet.AutoFilterMode = False Then
                .AutoFilter
            End If
            If ActiveSheet.AutoFilter.Filters(iColumn).On = True Then
                .AutoFilter Field:=iColumn
            Else
                .AutoFilter Field:=iColumn, Criteria1:=ActiveCell.Value
            End If
        End If
    End With
    Set rngData = Nothing
    Set rngTable = Nothing
    Application.ScreenUpdating = True
    FilterSave
End Sub


Paste this macro into a Routine Module :

Code: 
Option Explicit
Sub FilterSave()




    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim arr, hdr, strSearch
    Dim x As Long, lRow As Long, i  As Long
    Dim NewWBName As String
    
    NewWBName = ThisWorkbook.Path & "\" & Selection & ".xlsx"
    
    Application.ScreenUpdating = False
    hdr = Range("A1:O1")
    lRow = Cells(Rows.Count, 5).End(xlUp).Row
    arr = Range("E2:E" & lRow)
    
    With CreateObject("Scripting.Dictionary")
        For x = LBound(arr) To UBound(arr)
            If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
        Next
        strSearch = .KEYS
    End With
    
        With ws
            .Cells.SpecialCells(xlCellTypeVisible).Copy
    
            Workbooks.Add
            
            Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            ActiveSheet.UsedRange.Columns.AutoFit
            ActiveSheet.Range("A1:O1").Font.Bold = True
            ActiveSheet.Range("A1").Select
            
            ActiveWorkbook.SaveAs NewWBName
             
            ActiveWorkbook.Close
            .AutoFilterMode = False
            
        End With
  
            ws.Activate
            ws.Range("A1:O1").AutoFilter Field:=5
            Application.Goto Reference:=Worksheets("Sheet1").Range("A1"), scroll:=True
              
    Application.ScreenUpdating = True
    
End Sub


Download sample workbook : https://www.amazon.com/clouddrive/share/Oi61etJdp3R2JdwkvLe7R6HlTq5bYtR7oJVHc9yl90Z
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
VBA Transpose data from one sheet into another
Replies
9
Views
536
madi1004
M
P
  • Solved
Lookup based on multiple criteria
2 3
Replies
22
Views
758
paulkc
P
BigPaws
  • Question
VBA to create new worksheets from a template, populate the new worksheet by copying data from another sheet to specific locations.
Replies
0
Views
181
BigPaws
BigPaws
V
  • Question
Extract multiple data from one sheet to another
Replies
3
Views
607
vishu
V
sleek12
  • Question
Lookup values and add further worksheets to compare and contrast data
Replies
0
Views
386
sleek12
sleek12

Forum statistics

Threads
1,221,418
Messages
6,159,790
Members
451,589
Latest member
Harold14

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