VBA: creating new files per unique values

[PB7]

Hello VBA colleagues.

I am looking for some code which takes a spreadsheet, sort on names in Column E, and based on the different names (could be 30+ unique names in the column), creates a new, unique workbook with each unique name.

A new workbook for John Doe's records, a new workbook for Mary Smith's records, and so on.

Does anyone have anything quick and close to this solutiion?

Many thanks in advance to any attention and/or reply here.

 

[Domenic]

Try...

[font=Verdana][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CreateWorkbooks()

    [color=darkblue]Dim[/color] strMyPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbNew [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] rUniqueVals [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastColumn [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]With[/color] ActiveSheet.UsedRange
        LastRow = .Rows.Count + .Rows(1).Row - 1
        LastColumn = .Columns.Count + .Columns(1).Column - 1
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]If[/color] LastRow > 1 [color=darkblue]Then[/color]
    
        Application.ScreenUpdating = [color=darkblue]False[/color]
    
        [color=green]'Change the destination path accordingly[/color]
        strMyPath = "C:\Users\Domenic\Desktop\"
        
        [color=darkblue]If[/color] Right(strMyPath, 1) <> "\" [color=darkblue]Then[/color] strMyPath = strMyPath & "\"
        
        [color=darkblue]With[/color] Range(Cells(1, 1), Cells(LastRow, LastColumn))
            .Sort key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes, _
                ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        Range("E1:E" & LastRow).AdvancedFilter xlFilterInPlace, , , [color=darkblue]True[/color]
        
        [color=darkblue]Set[/color] rUniqueVals = Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible)
        
        [color=darkblue]For[/color] [color=darkblue]Each[/color] rCell [color=darkblue]In[/color] rUniqueVals
            [color=darkblue]Set[/color] wkbNew = Workbooks.Add(xlWBATWorksheet)
            wkbNew.SaveAs strMyPath & rCell.Value & ".xlsx", 51
            wkbNew.Close [color=darkblue]False[/color]
        [color=darkblue]Next[/color] rCell
        
        ActiveSheet.ShowAllData
        
        Application.ScreenUpdating = [color=darkblue]True[/color]
        
        MsgBox "Completed...", vbInformation
        
    [color=darkblue]Else[/color]
    
        MsgBox "No data is available...", vbExclamation
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]

 

[PB7]

Dominic, thanks, I will try this now. Sorry for the delay in responding.

 

[Domenic]

Sorry, I misunderstood your requirement. Try the following macro instead...

[font=Verdana][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CreateWorkbooks()

    [color=darkblue]Dim[/color] strMyPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbNew [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wksNew [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rUniqueVals [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastColumn [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]With[/color] ActiveSheet.UsedRange
        LastRow = .Rows.Count + .Rows(1).Row - 1
        LastColumn = .Columns.Count + .Columns(1).Column - 1
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]If[/color] LastRow > 1 [color=darkblue]Then[/color]
    
        Application.ScreenUpdating = [color=darkblue]False[/color]
    
        strMyPath = "C:\Users\Domenic\Desktop\"
        
        [color=darkblue]If[/color] Right(strMyPath, 1) <> "\" [color=darkblue]Then[/color] strMyPath = strMyPath & "\"
        
        [color=darkblue]With[/color] Range(Cells(1, 1), Cells(LastRow, LastColumn))
            .Sort key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes, _
                ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        Range("E1:E" & LastRow).AdvancedFilter xlFilterInPlace, , , [color=darkblue]True[/color]
        
        [color=darkblue]Set[/color] rUniqueVals = Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible)
        
        [color=darkblue]For[/color] [color=darkblue]Each[/color] rCell [color=darkblue]In[/color] rUniqueVals
            [color=darkblue]With[/color] ActiveSheet.UsedRange
                .AutoFilter field:=5, Criteria1:=rCell.Value
                .Copy
            [color=darkblue]End[/color] [color=darkblue]With[/color]
            [color=darkblue]Set[/color] wkbNew = Workbooks.Add(xlWBATWorksheet)
            [color=darkblue]Set[/color] wksNew = wkbNew.Worksheets(1)
            wksNew.Range("A1").PasteSpecial
            wkbNew.SaveAs strMyPath & rCell.Value & ".xlsx", 51
            wkbNew.Close [color=darkblue]False[/color]
        [color=darkblue]Next[/color] rCell
        
        ActiveSheet.ShowAllData
        
        Application.ScreenUpdating = [color=darkblue]True[/color]
        
        MsgBox "Completed...", vbInformation
        
    [color=darkblue]Else[/color]
    
        MsgBox "No data is available...", vbExclamation
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]

 

[PB7]

Domenic,

It worked a couple times, but usually, 98% of the time, I get this error message:

"Microsoft Office Excel cannot access the file c:\Users\Domenic
\Desktop\BFAFE200"


BFAFE200 is some random type number it picks up somehow.

Any clues as to what might be wrong...still? Thanks!

 

[Domenic]

You'll need to change the destination path. So you'll need to change this line of code...

strMyPath = "C:\Users\Domenic\Desktop\"

 

[Fazza]

This might be of interest too? From a site with some great resources. http://www.datapigtechnologies.com/freeware.htm

 

[JayMess]

Domenic,

This code was just what I was looking for - thanks for posting it.

I understood what you did except for two points:

With ActiveSheet.UsedRange
LastRow = .Rows.Count + .Rows(1).Row - 1
LastColumn = .Columns.Count + .Columns(1).Column - 1
End With

How do these formulas work? I don't understand the addition.

Also, second question:

How can you refer to rCell when you never assigned a value to it?

Thanks for expanding my understanding,

Jay

 

[Domenic]

Domenic,

This code was just what I was looking for - thanks for posting it.

You're very welcome!

I understood what you did except for two points:

With ActiveSheet.UsedRange
LastRow = .Rows.Count + .Rows(1).Row - 1
LastColumn = .Columns.Count + .Columns(1).Column - 1
End With

How do these formulas work? I don't understand the addition.

Let's assume that B10:D20 represents the used range:

.Rows.Count returns the number of rows within the used range, which in this case is 11.
[FONT=Verdana]
[/FONT].Rows(1) refers to the first row of the used range, which in this case is Row 10.
[FONT=Verdana]
[/FONT].Rows(1).Row returns the row number for the first row of the used range, which in this case is 10.

Therefore, we get the following...

LastRow = .Rows.Count + .Rows(1).Row - 1
[FONT=Verdana]
[/FONT]LastRow = 11 + 10 - 1
[FONT=Verdana]
LastRow = 20[/FONT]

Also, second question:

How can you refer to rCell when you never assigned a value to it?

For Each/Next allows you to loop through each element within an array or collection. In this example, rUniqueVals acts as a collection whose elements consists of Range objects. And, each Range object is represented by a control variable, which in this case is rCell. Note that you can use any valid variable name in its place.

Let's look at another example. Let's say that you want to loop through each worksheet within the active workbook and display each one of their names in a message box. For this we can use the following macro...

[FONT=Courier New][COLOR=darkblue]Sub[/COLOR] test()    
[COLOR=darkblue]    Dim[/COLOR] Wks [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] Wks [COLOR=darkblue]In[/COLOR] ActiveWorkbook.Worksheets
        MsgBox Wks.Name
    [COLOR=darkblue]Next[/COLOR] Wks
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
[/FONT]

Here, the worksheets within the active workbook is the collection, and Wks is the control variable that represents an element or worksheet within the collection. Again, we could have just as easily used another name for the variable. For example, we could have used Item instead of Wks. Also, note that since we're using For Each/Next we don't need to know how many elements/worksheets there are in the collection.