Thread: Filter, copy filtered data into another sheet, create a file of that sheet..

Hi there,

I have been searching the forum now for a while on filtering through VBA but the examples cited don't match what I am looking for, and I am not that good at VB to modify what I found to meet my requirements.

Here is what I need to do.

I have a list of items assigned to a person. There are a few persons in the list, each with different items belonging to them.

1. I would like to create a single sheet for each person, listing his items. If the sheets already exist (running the macro for the 2nd time, the contents should be erased and recreated)
2. I would like to have each person have his own excel FILE, so I can email it to them (e.g. peter.xls, maria.xls, frank.xls,...). Once again, if the excel file already exists, it can be deleted and replaced whenever the macro is run.

Attached please see an example.

NOTE: I don't want to manually autofilter in case anybody suggests that. This needs to be fully automated.

Thanks for your help, appreciate it!!
Titus

Just one more thing (sorry if it's too much to ask ;-).

Would it be possible to SORT the data in the created sheets and files in ASCENDING order by the number of items?

E.g.

2 shoes
3 horses
5 coffees

etc...

Thanks again ;-)
Titus

See attached file where I used this macro:

Private Sub cmd_Elaborate_Click()
   Dim rs, sh As Worksheet, r As Long, lastRow As Long
   Dim c As Integer, oldName As String, outRow As Long
   Dim myPath As String, newName As String
   Dim newWb As Workbook, newSh As Worksheet
   Dim outFileName As String
   
   Const adInteger = 3
   Const adDate = 7
   Const adVarChar = 200
   
   myPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\"))
   
   Set rs = CreateObject("ADODB.Recordset")
   'create recordset fileds
   With rs.fields
      .Append "name", adVarChar, 100
      .Append "items", adVarChar, 100
      .Append "mySort", adInteger
   End With
   rs.Open
   
   For Each sh In ThisWorkbook.Sheets
      lastRow = sh.Cells(Rows.Count, "a").End(xlUp).Row
      For r = 2 To lastRow
         rs.addnew
         rs("name") = sh.Cells(r, "a")
         rs("items") = sh.Cells(r, "b")
         rs("mySort") = CInt(Left(rs("items"), InStr(rs("items"), " ") - 1))
            
         rs.Update
      Next r
   Next sh

   'sort data for name and items
   rs.Sort = "name, mySort"
   
   'put data in new workbooks
   Application.ScreenUpdating = False
   Do While Not rs.EOF
      If rs(0) <> oldName Then
         If oldName <> "" Then
            newWb.Close SaveChanges:=True
         End If
         newName = rs(0)
         Set newWb = Workbooks.Add
         Set newSh = newWb.ActiveSheet
         
         outFileName = myPath & newName & ".xls"
         If Dir(outFileName) <> "" Then
            Kill outFileName
         End If
         newWb.SaveAs Filename:=myPath & newName, FileFormat:=xlNormal, _
               Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
               CreateBackup:=False
         
         'labels on top
         newSh.Cells(1, "a") = "Name"
         newSh.Cells(1, "b") = "Items"
         newSh.Range("1:1").Font.Bold = True
         
         outRow = 1
         oldName = newName
      End If
      
      outRow = outRow + 1
      For c = 1 To 2
         newSh.Cells(outRow, c) = rs(c - 1)
      Next c
      
      rs.moveNext
   Loop
   Application.ScreenUpdating = True
   
   newWb.Close SaveChanges:=True
   rs.Close
   Set rs = Nothing
   Set newWb = Nothing
   Set newSh = Nothing

   MsgBox ("Processing terminated")
End Sub

Regards,
Antonio

Wow, this is impressive! And it's working like a charm! Thanks so much, you're a genius!!

One more question though: if I have an Excel file with more columns of data, how I can get the macro to work, exporting files with all the other columns of data?

The logic stays the same: column1 contains the filename and column2 needs to be sorted by number.
Probably takes you 10 seconds, would mean hours to me ;-)

Thanks so much, this is really great!
Titus

This new version copy all the row in new sheets so it copies all columns.

Regards,
Antonio

I added label 'Color'.

Regards,
Antonio