Loop through filtered list for each value and copy data for each value onto a seperate workbook

Question

Hi,

I am still in the learning process of excel macros and I really need help with this function. The data I am working with has 1000+ rows but this small sample should be able to give you the idea of the data I am working with and the function I need help with.

So I am working with two files:

1. Main File

2: Template file

Function to perform:

Step 1

In the Main File filter column A and select first value  i.e 4231

select data from column B-D for that value and copy  i.e B2:D2

Open Template file

Pasted copied data on cell A6

Go back to Main File and copy the value i.e 4231

Open Template file and paste it in cell B1

Save file as value_1309.xls i.e 4231_1309.xls

Step 2

In the Main File autofilter on column a and select 2nd value  i.e 4284

select data from column B-D for that value and copy  i.e B3:D6

Open Template file

Paste copied data on cell A6

Go back to Main File and copy the value  i.e 4284

Open Template file and paste it in cell B1

Save file as value_1309.xls  i.e 4284_1309.xls

and so on for each filtered value until there are no more values remaining in column A

To summarize, basically I want the data in columns B-D for each filtered criteria in column A in a seperate workbook with the specifications listed in the steps.

Please help me with the vba code for this function, it will be greatly appreciated.

Answer 1

Try this:

Sub CopyData()

    ' Template path and filename

    Const strTemplate = "C:\Templates\MyTemplate.xlt"

    ' Path for workbooks, including trailing backslash

    Const strPath = "C:\Excel"

    Dim wbkSrc As Workbook

    Dim wshSrc As Worksheet

    Dim wbkTrg As Workbook

    Dim wshTrg As Worksheet

    Dim lngRow As Long

    Dim lngStartRow As Long

    Dim lngLastRow As Long

    Dim strFilename As String

    Application.ScreenUpdating = False

    Set wbkSrc = ActiveWorkbook

    Set wshSrc = wbkSrc.Worksheets("1-4 pcs") ' or ActiveSheet

    wshSrc.UsedRange.Sort Key1:=wshSrc.Range("A1"), Header:=xlYes

    lngLastRow = wshSrc.Range("A" & wshSrc.Rows.Count).End(xlUp).Row

    lngRow = 2

    Do

        If wshSrc.Range("A" & lngRow).Value <> wshSrc.Range("A" & lngRow - 1).Value Then

            If lngStartRow > 0 Then

                Set wbkTrg = Workbooks.Add(Template:=strTemplate)

                Set wshTrg = wbkTrg.Worksheets(1)

                wshTrg.Range("B1").Value = wshSrc.Range("A" & lngStartRow).Value

                wshSrc.Range("B" & lngStartRow & ":D" & lngRow - 1).Copy _

                    Destination:=wshTrg.Range("A6")

                strFilename = wshSrc.Range("A" & lngStartRow).Value & "_1309.xls"

                wbkTrg.SaveAs Filename:=strPath & strFilename, FileFormat:=xlExcel8

                wbkTrg.Close

            End If

            If lngRow > lngLastRow Then

                Exit Do

            Else

                lngStartRow = lngRow

            End If

        End If

        lngRow = lngRow + 1

    Loop

    Application.ScreenUpdating = True

End Sub

Answer 2

Hi,

try and this approach

(export, xls files in Active workook path)

[Edit..]

Sub macro_01()

Const Hcol As String = "W"   '<< Helper columnConst N As Long = 2  '<< data starts in row 2Const shName As String = "1-4 pcs"  '<< sheet nameConst myCol As String = "A"   '<< Numbers in column AConst tempPath As String = "C:\Documents and Settings\User\Templates"  '<< template path

Const tempName As String = "Temp File.xlt"  '<< template file name, changeDim myWB As Workbook, tempWB As Workbook

Set myWB = ThisWorkbook

Dim myPath

myPath = ThisWorkbook.Path & ""

Dim r As Long, rH As Long, x As Long

Application.ScreenUpdating = False

With myWB.Sheets(shName)

r = .Cells(Rows.Count, myCol).End(xlUp).Row

.Range(myCol & N - 1 & ":" & myCol & r).AdvancedFilter _

Action:=xlFilterCopy, CopyToRange:=.Range(Hcol & "1"), Unique:=True

rH = .Cells(Rows.Count, Hcol).End(xlUp).Row

For x = 2 To rH

.AutoFilterMode = False

.Range(myCol & N - 1 & ":" & myCol & r).AutoFilter field:=1, _

Criteria1:=.Cells(x, Hcol)

Set tempWB = Workbooks.Add(tempPath & tempName)

.Range("B" & N & ":D" & r).SpecialCells(xlCellTypeVisible).Copy Sheets(1).Range("A6")

.Cells(x, Hcol).Copy Sheets(1).Range("B1")

Application.DisplayAlerts = False

tempWB.SaveAs Filename:=myPath & .Cells(x, Hcol) & "_1309.xls", FileFormat:=xlNormal

Application.DisplayAlerts = True

tempWB.Close

Next

.AutoFilterMode = False

.Range(Hcol & ":" & Hcol).Clear

End With

ActiveWorkbook.Save

Application.ScreenUpdating = True

End Sub

Note

in path "C:\Documents and Settings\User\Templates"the templates folder, is a hidden folder in windows xp

(i'm using windows xp and xl2003)

Answer 3

Thank you so much!! This works perfectly.

You saved me SO much time!

I have one small request if possible - I am in the process of learning vba myself, if you could break it down for me with comments, that would be awesome. Its all good if you don't have time for it though.

Thank you so much once again!

Answer 4

Thank you so much!! You guys are awesome!

Answer 5

I have one small request if possible - I am in the process of learning vba myself, if you could break it down for me with comments, that would be awesome. Its all good if you don't have time for it though.

Thank you so much once again!

After declaring the variables that are used in the macro, the code starts by setting a reference to the active workbook and to the relevant worksheet in that workbook:

    Set wbkSrc = ActiveWorkbook

    Set wshSrc = wbkSrc.Worksheets("1-4 pcs") ' or ActiveSheet

To be on the safe side, the data in that sheet are sorted on column A:

    wshSrc.UsedRange.Sort Key1:=wshSrc.Range("A1"), Header:=xlYes

We determine the last used row:

    lngLastRow = wshSrc.Range("A" & wshSrc.Rows.Count).End(xlUp).Row

We then start looping through the rows at row 2

    lngRow = 2

    Do

        ...

    Loop

Within the loop, we check whether the value in column A in the current row (lngRow) is different from that in the previous row (lngRow - 1). If so, we're starting a new series.

We check whether we have a series "pending". If so, we create a new workbook from the template and copy the rows from that series to the new workbook, then save and close it.

If we're past the last used row, we're done, and we can exit the loop.

Otherwise, the value of the current row is assigned to lngStartRow to save the first row of the new series.

We then increase the row number and loop back.