Challenge: filtering - splitting - saving from 1 Masterfile

ba99

New Member
Joined
Jul 25, 2007
Messages
4
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
ABCD
1PersonData
2John50
3Michael45
4Michael40
5Peter35
6John30
7Richard25
8Peter20
9Richard15
10John10
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
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

rbrhodes

Board Regular
Joined
May 25, 2007
Messages
69
Hi ba99,

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

Cheers,

dr
 

ba99

New Member
Joined
Jul 25, 2007
Messages
4
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

Board Regular
Joined
May 25, 2007
Messages
69
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

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
Hi
One way
try
Code:
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

Well-known Member
Joined
Apr 28, 2004
Messages
76,286
Office Version
  1. 365
Platform
  1. Windows
This can be done using advanced filter.

Here's an example.
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,112
Messages
5,640,167
Members
417,128
Latest member
Xianter

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top