Create new workbooks out of unique data within a single column

[rtc123]

Hi all,

I have been struggling to develop a VBA process that identifies unique values within one column of a single worksheet, within a workbook with multiple worksheets. I want the process to create a new workbook for each unique value with all of the same worksheets, but within the worksheet with the unique value, I just want those values and not the entire selection of values to show up within the new worksheet/workbook. This should loop through all unique values within that column. Below are the two Subs I've created, Sub createDataTab() copies the master data tab so I don't delete data from it, and Sub createWorkbook() should loop through all the unique data variables in column C of the "Data_Tab" worksheet. I can further explain as the thread goes along, but any ideas would be great. Thanks.

Sub createDataTab()

For Each ws In Worksheets
If ws.Name = "Data_Test" Then
Application.DisplayAlerts = False
Sheets("Data_Test").Delete
Application.DisplayAlerts = True

Sheets("Data").Copy after:=Sheets("UserForm")
ActiveSheet.Name = "Data_Test"
End
End If
Next


End Sub




Sub createWorkbook()


cell = ActiveWorkbook.Worksheets("Scorecard-Raw").Range("C2").Value
Fpath = "C:\Users\rcherry1\Desktop\Macro Project_Peter\Itemized Categories"
Fname = Fpath & cell & ".xlsm"


Do Until IsEmpty(ActiveWorkbook.Worksheets("Data_Test").Range("C2").Value)


ActiveWorkbook.Worksheets("Data_Test").Select
Range("A2:AZ2").Select
Selection.Copy
ActiveWorkbook.Worksheets("Scorecard-Raw").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False




For Each cell In Sheets("Data_Test").Range("C:C")
If cell.Value = Worksheets("Scorecard-Raw").Range("C2") Then
Application.DisplayAlerts = False
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Resize(1, 52).Cut

Sheets("Scorecard-Raw").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Data_Test").Select
Application.DisplayAlerts = True
End If
Next


ActiveWorkbook.Worksheets("Scorecard-Raw").Select
Range("C2:C5000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveWorkbook.Worksheets("Data_Test").Select
Range("A2:BH2").Delete
Range("C2:C5000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

ActiveWorkbook.SaveCopyAs Filename:=Fname

ActiveWorkbook.Worksheets("Scorecard-Master").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Scorecard-Raw").Select
Cells.Select
ActiveSheet.Paste

Loop



End Sub

 

[Fluff]

Is this what you're after?

Sub CreateWorkbook()

    Dim Cl As Range
    Dim Pth As String
    Dim DataSht As Worksheet
    Dim Dict As Object
    
[COLOR=#0000ff]Application.ScreenUpdating = False[/COLOR]
    
    Pth = "C:\Users\rcherry1\Desktop\Macro Project_Peter\Itemized Categories\"
    
    With Sheets("Data")
    Set Dict = CreateObject("scripting.dictionary")
        For Each Cl In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
            If Not Dict.exists(Cl.Value) Then
                Dict.Add Cl.Value, Nothing
                Sheets.Copy
                Set DataSht = ActiveWorkbook.Sheets("Data")
                DataSht.Range("C:C").AutoFilter field:=1, Criteria1:="<>" & Cl.Value
                DataSht.Range("A2", DataSht.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlVisible).EntireRow.Delete
                DataSht.AutoFilterMode = False
                ActiveWorkbook.SaveAs Pth & Cl.Value, 52
                ActiveWorkbook.Close False
            End If
            Set DataSht = Nothing
        Next Cl
    End With
    

End Sub

 

[rtc123]

Fluff,

Thanks so much for your input. That's VERY close to what I'm looking for. It's fantastic that each category within column C is compiled into separate workbooks, and that each tab is copied. The only interim step I'd be looking to accomplish before creating new workbooks for each category name, is to copy and paste columns A:AZ from the Data tab (after the sorting has completed) into the "Scorecard-Raw" tab. I believe this step could be a simple copy/paste action between these two code lines:

ActiveWorkbook.SaveAs Pth & Cl.Value, 52
ActiveWorkbook.Close False

Does that seems right?

Thanks!

 

[Fluff]

This will clear th Scorecard sheet & then copy the data over

Sub CreateWorkbook()

    Dim Cl As Range
    Dim Pth As String
    Dim DataSht As Worksheet
    Dim Dict As Object
    
Application.ScreenUpdating = False
    
    Pth = "C:\Users\rcherry1\Desktop\Macro Project_Peter\Itemized Categories\"
    
    With Sheets("Data")
    Set Dict = CreateObject("scripting.dictionary")
        For Each Cl In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
            If Not Dict.exists(Cl.Value) Then
                Dict.Add Cl.Value, Nothing
                Sheets.Copy
                Set DataSht = ActiveWorkbook.Sheets("Data")
                DataSht.Range("C:C").AutoFilter field:=1, Criteria1:="<>" & Cl.Value
                DataSht.Range("A2", DataSht.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlVisible).EntireRow.Delete
                DataSht.AutoFilterMode = False
                [COLOR=#0000ff]Sheets("Scorecard-Raw").UsedRange.ClearContents
                DataSht.Range("A1").CurrentRegion.Copy Sheets("Scorecard-Raw").Range("A1")[/COLOR]
                ActiveWorkbook.SaveAs Pth & Cl.Value, 52
                ActiveWorkbook.Close False
            End If
            Set DataSht = Nothing
        Next Cl
    End With

End Sub

 

[rtc123]

That's fantastic, I altered it a little to only grab up through column AZ, and to avoid selecting headers:

Sheets("Scorecard-Raw").Range("A2:AZ5000").ClearContents
DataSht.Range("A2:AZ5000").Copy Sheets("Scorecard-Raw").Range("A2")

But I cannot thank you enough for such a succinct and efficient code. Any tips for learning how to create such good code?

 

[Fluff]

Glad to help & thanks for the feedback.

As for learning VBA, I've learn't most of what I know from this site. Either by looking at various threads & trying to understand what's happening, or by helping others, when other members post their suggestions.
That said there are plenty of websites dealing with VBA & Hiker95 has put together a pretty comprehensive list which can be found here
https://www.mrexcel.com/forum/general-excel-discussion-other-questions/1026346-vba.html#post4926066

 

[Rado88]

Is this what you're after?

Sub CreateWorkbook()

    Dim Cl As Range
    Dim Pth As String
    Dim DataSht As Worksheet
    Dim Dict As Object
    
[COLOR=#0000ff]Application.ScreenUpdating = False[/COLOR]
    
    Pth = "C:\Users\rcherry1\Desktop\Macro Project_Peter\Itemized Categories\"
    
    With Sheets("Data")
    Set Dict = CreateObject("scripting.dictionary")
        For Each Cl In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
            If Not Dict.exists(Cl.Value) Then
                Dict.Add Cl.Value, Nothing
                Sheets.Copy
                Set DataSht = ActiveWorkbook.Sheets("Data")
                DataSht.Range("C:C").AutoFilter field:=1, Criteria1:="<>" & Cl.Value
                DataSht.Range("A2", DataSht.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlVisible).EntireRow.Delete
                DataSht.AutoFilterMode = False
                ActiveWorkbook.SaveAs Pth & Cl.Value, 52
                ActiveWorkbook.Close False
            End If
            Set DataSht = Nothing
        Next Cl
    End With
    

End Sub

Hi @Fluff

I'm still trying to learn more about scripting.dictionary and therefore I've two queries to the above macro you created.

1) Is it possible to update this macro not only to create a new worksheet but also copy only rows with C1 Values (Unique ones) into those new worksheets ( row C1 Unique value lets say "A" to new workbook "A", row C1 Unique value "B" to woorkbook "B").

2) Furthermore is it possible to copy also the headers from original workbook (on which this macro works) to all new workbooks and save all of them as xlsx instead of xlsm?

I'm trying to do this with Dim Ky As Variant, K As Variant, but I can't seem to make it work I just want to understand how to work with scripting.dictionary

 

[Fluff]

That code does everything you've asked for, except it saves as xlsm rather than xlsx.

 

[Rado88]

That code does everything you've asked for, except it saves as xlsm rather than xlsx.

Yes but it copies all positions from master sheet ( to New sheet1 in New woorkbooks) instead only those with the same name as file name in range C1.

It all doesen't copy the headers

 

[Fluff]

Firstly it does copy the header row, as that is what it was designed to do. If it's not copying yours that's because your data is different to the OPs.
Secondly I have no idea, you are now contradicting yourself, you initially asked for all unique values (which the code does) now yo want it to match a specific value.
Thirdly as this is now a different question to the OP, please start a new thread