Macro to Filter & Extract Data to a New Workbook

**foxluc** · 12-05-2011, 06:19 AM

Hi everyone,
I'm stuck here, trying to write a macro that would filter data out of active worksheet and extract it into a new workbook. Please view attached file for reference.

I need the macro to filter the data in Activesheet (which would be protected except for column C) and extract each row in which there's a record of items being sold (C<>B; D>0; F>0). The data in column C would be entered manually.

Also it would be nice if at the same time the macro could copy entire column C and paste it into column B on sheet Stock (which would be hidden) so that the Items Left would represent new amounts of Items in stock. Anyway. this second feature is not of a top priority

Thank you for your time, friends.

**JapanDave** · 12-05-2011, 06:37 AM

I don't follow, what data are you trying to extract?

**foxluc** · 12-05-2011, 06:42 AM

All of those rows from Activesheet in which there's a record in column C (and C does not equal B) i.e. I need a list of all items that were sold.

**snb** · 12-05-2011, 06:58 AM

You can use autofilter or advancedfilter.

**foxluc** · 12-05-2011, 07:06 AM

Originally Posted by snb

You can use autofilter or advancedfilter.

That doesn't help at all since the workbook will be used by people who don't do copy&paste let alone advanced filter.

**snb** · 12-05-2011, 07:31 AM

You can use either method in a macro, so the user only has to click a button etc.

**foxluc** · 12-05-2011, 08:38 AM

Easy enough, mate

**JapanDave** · 12-05-2011, 09:53 AM

Not exactly sure this is what you are after, but here is the code anyway.

Code:

Dim ws As Worksheet
    Dim LR As Long
    Dim ws1 As Worksheet
    Dim i As Long
    Dim Wk As Workbook
    Dim j As Long
       Application.ScreenUpdating = False
            Set ws = Worksheets("Activesheet")
            Set ws1 = Worksheets("Stock")
            Set Wk1 = Workbooks.Add()
                 LR = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
             j = 2
                 For i = 2 To LR
                   If ws.Range("C" & i).Value <> "" Then
                        Wk1.Worksheets("Sheet1").Range("A" & j).Resize(, 7).Value = ws.Range("A" & i).Resize(, 7).Value
                    j = j + 1
                   End If
                 Next i
                 With Wk1
                      .Worksheets("Sheet1").Range("A1:G1") = ws.Range("A1:G1").Value
                      .Worksheets("Sheet1").Range("A1:G1").EntireColumn.AutoFit
                 End With
                 Wk1.Worksheets("Sheet1").Range("A1:G1").Select
                 With Selection.Borders
                   .LineStyle = xlContinuous
                   .Weight = xlThin
                   .ColorIndex = xlAutomatic
                 End With
                 With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 13434879
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                 End With
             ws1.Visible = True
                 ws1.Range("B2:B" & LR).Value = ws.Range("C2:C" & LR).Value
             ws1.Visible = False
            Wk1.SaveAs "C:\Users\Owner\Desktop\YourFileName.xlsx", FileFormat:=51
        Application.ScreenUpdating = True
End Sub

Cheers