Challenge: filtering - splitting - saving from 1 Masterfile

[ba99]

I'm wondering if the following challenge can be solvedwith VBA / macro's, or that it is too complex...

The following is a simplified version of a large sheet of data:

Book1.xls
	A	B	C	D
1	Person	Data
2	John	50
3	Michael	45
4	Michael	40
5	Peter	35
6	John	30
7	Richard	25
8	Peter	20
9	Richard	15
10	John	10
Sheet1

Challenge: each person needs to get one file, only containing their rows of data because they have to check theirs.

For reasons of portability, the other person's data needs to be deleted (so not filtered out and hidden)

Current manual solution for creating John's file:
1. custom autofilter on everthing not equal to John
2. delete the remaining data after autofilter
3. autofilter show all
4. file > save as > "book1 - john.xls"
5. open original book1 again, and repeat step 1-4 for Peter...Michael... etc

To what extent can this be automated??

I think step 1-3 are more simple than 4-5, but cannot even solve 1-3...

I'm curious! Thanks in advance,
BA

 

[rbrhodes]

Hi ba99,

Is this HTML code in an excel aheet displaying as is? Or...

Cheers,

dr

 

[ba99]

Oops... used the wrong code maker.
Thanks dr

Note: this is really a simplified version, the actual file contains about 18k rows, and 30 columns

 

[rbrhodes]

Hi,

One more:

So John is 10, 30 and 50. Do you just want to save that info or save that and rows 10, 30 and 50 or ?

Cheers,

dr

 

[jindon]

Hi
One way
try

Sub test()
Dim a, i As Long, ii As Long, w(), myDir As String, x, y, z As Long
a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
With CreateObject("VBScript.RegExp")
     .CompareMode = vbTextCompare
     For i = 2 To UBound(a,1)
          If Not IsEmpty(a(i,1)) Then
               If Not .exists(a(i,1)) Then
                    ReDim w(1 To UBound(a,2), 1 To 1)
                    For i = 1 To UBound(a,2) : w(ii,1) = a(i,ii) : Next
               Esle
                    w = .item(a(i,1))
                    ReDim Preserve w(1 To UBound(a,2), 1 To UBound(w,2) + 1)
                    z = UBound(w,2)
                    For ii = 1 To UBound(a,2) : w(ii,z) = a(i,ii) : Next
                    .item(a(i,1)) = w
              End If
          End If
     Next
     x = .keys : y = .items : Erase a
End With
For i = 0 To UBound(x)
     Set wb = Workbooks.Add
     wb.Sheets(1).Range("a1").Resize(UBound(y(i),2), UBound(y(i),1)).Value = _
          WorksheetFunction.Transpose(y(i))
     wb.SaveAs(ThisWorkbook.Path & "\Book1 - " & x(i) & ".xls"
     wb.Close False
Next
End Sub

 

[Norie]

This can be done using advanced filter.

Here's an example.

Sub DistributeRowsToNewWBS()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
    
    Set wsData = Worksheets("Master (2)")
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    wsData.Range("A1:A" & LastRow).AdvancedFilter action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        wsData.Range("A1:E" & LastRow).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        wsNew.Copy
        Set wbNew = ActiveWorkbook
        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
        wbNew.Close SaveChanges:=True
        Application.DisplayAlerts = False
        wsNew.Delete
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
    
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub