HELP! Loop macro to split one workbook into many

[DLE2885]

Hi Everyone

Please can someone help me? I'm a complete novice with VBA but I really need a macro for work.

I have a master spreadsheet eg:

<table frame="VOID" rules="NONE" border="0" cellspacing="0" cols="3"> <colgroup><col width="86"><col width="86"><col width="86"></colgroup> <tbody> <tr> <td align="LEFT" height="17" width="86">Name</td> <td align="LEFT" width="86">Product ID</td> <td align="LEFT" width="86">Result</td> </tr> <tr> <td align="LEFT" height="17">Steve</td> <td align="center">57</td> <td align="LEFT">good</td> </tr> <tr> <td align="LEFT" height="17">Dave</td> <td align="center">57</td> <td align="LEFT">good</td> </tr> <tr> <td align="LEFT" height="17">Steve</td> <td align="center">60</td> <td align="LEFT">ok</td> </tr> <tr> <td align="LEFT" height="17">Steve</td> <td align="center">56</td> <td align="LEFT">ok</td> </tr> <tr> <td align="LEFT" height="17">Steve</td> <td align="center">34</td> <td align="LEFT">good</td> </tr> <tr> <td align="LEFT" height="17">Dave</td> <td align="center">56</td> <td align="LEFT">bad</td> </tr> <tr> <td align="LEFT" height="17">Dave</td> <td align="center">23</td> <td align="LEFT">bad</td> </tr> </tbody> </table>
And I need a looping macro to create a new workbook (i.e. not a sheet within the existing workbook) which is named Dave.xls and Steve.xls

I want the headers included and the formatting to remain the same if possible.

I would also like to define the location to save them.

Is this possible?

I was asked to make it a looping macro because previous filters have not worked - it's a very large spreadsheet.

I was also asked to provide a failsafe check which I understood as being some kind of check which ensured that Dave.xls only had Dave's information in it and that all of Dave's information was in Dave.xls. I'm not sure if this is possible, so it's ok if not.

Many thanks for your help!!

 

[Sektor]

Sub DaveAndSteve()
 
    Dim i As Long, lr As Long
    Dim rng As Range
    Dim sh As Worksheet
    Dim book As Workbook
    Dim sheet As Worksheet
    Dim names As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False 

    Set sh = ActiveSheet
    names = VBA.Array("Steve", "Dave")
    
    With sh
        
        For i = 0 To UBound(names)
            ' Remove filter
            If .AutoFilterMode Then .AutoFilter.Range.AutoFilter
            lr = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A1:A3").AutoFilter Field:=1, Criteria1:=names(i)
            Set rng = .Range("A2:E" & lr).SpecialCells(xlCellTypeVisible)
            Set book = Workbooks.Add
            Set sheet = book.Sheets(1)
            With sheet
                .Range("A1:C1") = Array("Name", "Product ID", "Result")
                rng.Copy .Range("A2")
            End With
            book.Close SaveChanges:=True, Filename:="C:\" & names(i) & ".xlsx"
        Next
        
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

 End Sub

Or, by eliminating some code:

Sub DaveAndSteve()
 
    Dim i As Long, lr As Long
    Dim rng As Range
    Dim names As Variant
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    names = VBA.Array("Steve", "Dave")
    
    With ActiveSheet
        
        For i = 0 To UBound(names)
            If .AutoFilterMode Then .AutoFilter.Range.AutoFilter 'Remove filter
            lr = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A1:A3").AutoFilter Field:=1, Criteria1:=names(i)
            Set rng = .Range("A2:E" & lr).SpecialCells(xlCellTypeVisible)
            With Workbooks.Add
                With .Sheets(1)
                    .Range("A1:C1") = Array("Name", "Product ID", "Result")
                    rng.Copy .Range("A2")
                End With
                .Close SaveChanges:=True, Filename:="C:\" & names(i) & ".xlsx"
            End With
        Next
        
    End With
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
 End Sub

 

[DLE2885]

Thank you so much for your response!

Please can you show me how to change the code so that that there can be a varied number of names other than Dave and Steve please? ie. so that it it just names the new workbook whatever is in cell A?

Thank you so much!

 

[DLE2885]

Actually, I just realised this is using autofilter, which I was asked not to use because it caused problems last time...the worksheet is massive. I was asked to use a loop.

 

[Sektor]

Then you need to use SQL query!

 

[DLE2885]

I tried using this example I found on microsoft's website:


Sub CreateWorkbooks() Dim newSheet As Worksheet, regionSheet As Worksheet Dim cell As Object Dim regionRange As String Set regionSheet = Sheets("REGION SHEET") ' Turn off screen updating to increase performance. Application.ScreenUpdating = False ' Build a string that specifies the cells in column B that ' contain region names starting from cell B4. regionRange = "B4:" & regionSheet.Range("B4").End(xlDown).Address For Each cell In regionSheet.Range(regionRange) If SheetExists(cell.Value) = False Then ' Add a new worksheet. Sheets.Add After:=Sheets(Sheets.Count) ' Set newSheet variable to the new worksheet. Set newSheet = ActiveSheet ' Copy boilerplate data from first three rows ' of the master worksheet to the range starting at ' A1 in the new sheet. regionSheet.Range("A1:A3").EntireRow.Copy newSheet.Range("A1") ' Copy and paste the column widths to the new sheet. regionSheet.Range("A1:A3").EntireRow.Copy newSheet.Range("A1").PasteSpecial xlPasteColumnWidths ' Copy the entire row for the current region and ' paste starting at cell A4 in the new sheet. cell.EntireRow.Copy newSheet.Range("A4") ' Name the new sheet. newSheet.Name = cell.Value ' Call the SaveWorkbook function to save the current ' worksheet as a new workbook file. SaveWorkbook (cell.Value) ' Turn off alerts, and then delete the new worksheet ' from the current workbook. Application.DisplayAlerts = False newSheet.Delete ' Turn alerts back on. Application.DisplayAlerts = True End If Next Cell ' Notify the user that the process is complete. MsgBox "All workbooks have been created successfully" ' Turn screen updating back on. Application.ScreenUpdating = True End Sub

But I get a "compile error - sub or function not defined" on this line:

If SheetExists(cell.Value) = False Then

any ideas?
</pre>

 

[DLE2885]

argh. I don't know why it pasted all funny!

 

[Sektor]

Sub SqlQuery()

    Dim i As Integer
    Dim names As Variant
    Dim rs As ADODB.Recordset
    Dim SQL As String, sConnString As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    names = VBA.Array("Dave", "Steve")

    sConnString = _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
    
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseClient
    
    For i = 0 To UBound(names)
    
        SQL = "SELECT Name, [Product ID], Result " & _
              "FROM [" & ActiveSheet.Name & "$] " & _
              "WHERE Name = '" & names(i) & "';"
              
        rs.Open SQL, sConnString, adOpenForwardOnly, adLockReadOnly, adCmdText
        
        If rs.RecordCount > 1 Then
            
            With Workbooks.Add
                With .Sheets(1)
                    .Range("A1:C1") = Array("Name", "Product ID", "Result")
                    .Range("A2").CopyFromRecordset rs
                End With
                .Close SaveChanges:=True, Filename:="C:\" & names(i) & ".xlsx"
            End With
            
        End If
        
        rs.Close
        
    Next
    
    ' Clean up our Recordset object.
    Set rs = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

 

[Norie]

You don't need to use SQL for this.

You can use advanced filter to get a unique list if names.

Then loop through that list and, with each name as criteria, extract the data for each name to a new worksheet.

You want to create a new workbook for each person just move the new sheet.

You'll find examples of code for this if you search.

PS I know this uses filters but I can't see why you can't use filters.

 

[Sektor]

And set checkbox here: Tools -> References -> Microsoft ActiveX Data Objects 2.8 Library.