Create new workbooks based on cell content?

[TheWennerWoman]

I've got what is (to me) quite a daunting task although I am sure the gurus here will find this relatively simple.

I have a workbook with two tabs, Sheet1 and Sheet2.

Sheet1 contains nine columns, columns A-G are populated, columns H & I are for user input. Column A is the important one.

(Sorry, I can't get xl2BB to work otherwise I'd have used that)

PNumber PName CNumber CName ANumber AName Plan
A400000 James C343434 Truss Q456456 Patel Ford
A400009 Price C345578 Jones Q458888 Young Fiat
A400009 Capel C399000 Russi Q458888 Young Fiat

What I would like to do is create a new workbook based on column A. So, in the above example, I would end up with a workbook named A400000 containing one record (and the header row) and a workbook named A400009 containing two records (and the header row).

That's the first part. The second part relates to Sheet2. Sheet2 contains two columns

PNumber AName
A400000 Smith
A400000 Patel
A400000 Jackson
A400000 Roberts
A400009 Young
A400009 Morris
A400009 Peters

In addition to the first part, I'd like to add into the newly created file (on a new sheet) anything from Sheet2 that relates to the file created. So, the file created earlier named A400000 would have a second sheet containing the four records above (Smith, Patel, Jackson, Roberts) and the file created earlier named A400009 would have a second sheet containing the three records above (Young, Morris, Peters).

Any thoughts greatly appreciated as always.

Thank you for reading.

 

[kevin9999]

Try the following - creates the new files & saves them in the same folder as your original.

Option Explicit
Sub Wenner()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")   '<~~ *** Change to your actual sheet name ***
    
    Dim a, i As Long
    a = WorksheetFunction.Unique(ws1.Range("A2:A" & ws1.Cells(Rows.Count, "A").End(xlUp).Row))
    
    For i = LBound(a) To UBound(a)
        Worksheets(Array("Sheet1", "Sheet2")).Copy  '<~~ *** Change to your actual sheet names ***
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
        Application.DisplayAlerts = True
        With ActiveWorkbook.Worksheets(1).Range("A1").CurrentRegion
            .AutoFilter 1, "<>" & a(i, 1)
            .Offset(1).EntireRow.Delete
            .AutoFilter
            .Columns("H:I").EntireColumn.ClearContents
        End With
        With ActiveWorkbook.Worksheets(2).Range("A1").CurrentRegion
            .AutoFilter 1, "<>" & a(i, 1)
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
        ActiveWorkbook.Close True
    Next i
    
    Application.ScreenUpdating = True
End Sub

 

[TheWennerWoman]

Thank you for that. It correctly creates the files, correctly populates Sheet1 in both files but Sheet2 in both files is blank (headers are there but no data).

Any thoughts?

Thanks in advance.

 

[kevin9999]

but Sheet2 in both files is blank (headers are there but no data).

Unfortunately, that's not what happens when I run the code, based on what I think your data looks like. For example, in the first file created I get this in sheet 2:

A400000.xlsx
	A	B
1	PNumber	AName
2	A400000	Smith
3	A400000	Patel
4	A400000	Jackson
5	A400000	Roberts
6
Sheet2

I note you can't get XL2BB to work. If you want me to look at this further, I'll need to see your actual workbook. You can share via Dropbox, Google Drive or similar file sharing platform. Otherwise, I'm afraid there's not much I can do.

 

[TheWennerWoman]

Book1
	A	B	C	D	E	F	G	H	I
1	PNumber	PName	CNumber	CName	ANumber	AName	Plan	input1	input2
2	A400000	James	C343434	Truss	Q456456	Patel	Ford
3	A400009	Price	C345578	Jones	Q458888	Young	Fiat
4	A400009	Capel	C399000	Russi	Q458888	Young	Fiat
Sheet1

Book1
	A	B
1	PNumber	AName
2	A400000	Smith
3	A400000	Patel
4	A400000	Jackson
5	A400000	Roberts
6	A400009	Young
7	A400009	Morris
8	A400009	Peters
Sheet2

Ok I have got XL2BB to work on my home pc, must be something twitchy with the corporate environment.

Can you use this to check that it's something I'm doing wrong? (I can't run your code at home, I'm using Office 2010 and

UNIQUE

isn't supported on that platform.

Many thanks for your assistance, it is greatly appreciated.

 

[kevin9999]

Thanks for that. The lack of access to the Unique() function certainly makes all the difference. Amending the code (using a dictionary to get the unique items) like below:

Option Explicit
Sub Wenner_V2()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")   '<~~ *** Change to your actual sheet name ***
   
    Dim d As Object, r As Range, c, a, i As Long
    Set d = CreateObject("scripting.dictionary")
    For Each r In ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))
        For Each c In Split(r, ",")
            d(c) = 1
        Next c
    Next r
    a = Application.Transpose(d.keys)
       
    For i = LBound(a) To UBound(a)
        Worksheets(Array("Sheet1", "Sheet2")).Copy  '<~~ *** Change to your actual sheet names ***
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
        Application.DisplayAlerts = True
        With ActiveWorkbook.Worksheets(1).Range("A1").CurrentRegion
            .AutoFilter 1, "<>" & a(i, 1)
            .Offset(1).EntireRow.Delete
            .AutoFilter
            .Columns("H:I").EntireColumn.ClearContents
        End With
        With ActiveWorkbook.Worksheets(2).Range("A1").CurrentRegion
            .AutoFilter 1, "<>" & a(i, 1)
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
        ActiveWorkbook.Close True
    Next i
   
    Application.ScreenUpdating = True
End Sub

Results in the following outputs using your supplied data:

A400000.xlsx
	A	B	C	D	E	F	G
1	PNumber	PName	CNumber	CName	ANumber	AName	Plan
2	A400000	James	C343434	Truss	Q456456	Patel	Ford
3
Sheet1

A400000.xlsx
	A	B
1	PNumber	AName
2	A400000	Smith
3	A400000	Patel
4	A400000	Jackson
5	A400000	Roberts
6
Sheet2

A400009.xlsx
	A	B	C	D	E	F	G
1	PNumber	PName	CNumber	CName	ANumber	AName	Plan
2	A400009	Price	C345578	Jones	Q458888	Young	Fiat
3	A400009	Capel	C399000	Russi	Q458888	Young	Fiat
4
Sheet1

A400009.xlsx
	A	B
1	PNumber	AName
2	A400009	Young
3	A400009	Morris
4	A400009	Peters
5
Sheet2

Hopefully, that fixes the problem. Let me know how the new code works out for you

 

[TheWennerWoman]

Outstanding - works a treat, I can't thank you enough.

One nice-to-have but not essential (and apologies if I need to start a new thread)......in the newly created workbooks, is it possible to have column H on Sheet1 have a list dropdown that picks from column B of Sheet2?

The only reason I ask is if we allow the users free text data entry they could spell Morris, for example, Maurice, Moriss, Morriss etc etc. If we force them to use a dropdown populated by what we know the correct spellings are, that will eliminate validation errors.

Thank you again for what you have supplied.

 

[kevin9999]

Outstanding - works a treat, I can't thank you enough.

One nice-to-have but not essential (and apologies if I need to start a new thread)......in the newly created workbooks, is it possible to have column H on Sheet1 have a list dropdown that picks from column B of Sheet2?

The only reason I ask is if we allow the users free text data entry they could spell Morris, for example, Maurice, Moriss, Morriss etc etc. If we force them to use a dropdown populated by what we know the correct spellings are, that will eliminate validation errors.

Thank you again for what you have supplied.

Happy to help, and thanks for the feedback
What you're asking for is possible, but I'm switching off for tonight so I'll have a look at it tomorrow

 

[kevin9999]

is it possible to have column H on Sheet1 have a list dropdown that picks from column B of Sheet2?

Which cell do you want the dropdown to apply to? H1, H2, or something else?

 

[kevin9999]

Try this to start with (puts the dropdown in cell H2 of the newly created files). We can amend if it's not quite what you wanted, but that will be tomorrow

Option Explicit
Sub Wenner_V3()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")   '<~~ *** Change to your actual sheet name ***
    
    Dim d As Object, r As Range, c, a, i As Long
    Set d = CreateObject("scripting.dictionary")
    For Each r In ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))
        For Each c In Split(r, ",")
            d(c) = 1
        Next c
    Next r
    a = Application.Transpose(d.keys)
        
    For i = LBound(a) To UBound(a)
        Worksheets(Array("Sheet1", "Sheet2")).Copy  '<~~ *** Change to your actual sheet names ***
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
        Application.DisplayAlerts = True
        With ActiveWorkbook.Worksheets(1).Range("A1").CurrentRegion
            .AutoFilter 1, "<>" & a(i, 1)
            .Offset(1).EntireRow.Delete
            .AutoFilter
            .Columns("H:I").EntireColumn.ClearContents
        End With
        With ActiveWorkbook.Worksheets(2).Range("A1").CurrentRegion
            .AutoFilter 1, "<>" & a(i, 1)
            .Offset(1).EntireRow.Delete
            .AutoFilter
            .Range("B2", .Cells(Rows.Count, "B").End(xlUp)).Name = "ValList"
        End With
        
        With ActiveWorkbook.Worksheets(1).Range("H2").Validation
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=ValList"
            .IgnoreBlank = True
            .InCellDropdown = True
        End With
        With ActiveWorkbook
            .Worksheets(1).Range("H2").Select
            .Close True
        End With
    Next i
    
    Application.ScreenUpdating = True
End Sub