Create a new Workbook for each unique row in Excel VBA

Question

As shown in the image, I had the raw data (A2:C6) and I want to create a new workbook based on each unique value in columns B. In the example, there are 4 colors in the "Color" column and 3 unique colors, so I would create 3 different new workbooks (Red.xlsx, Yellow.xlsx, and Orange.xlsx) as shown in the bottom part of the image.

So the code I have in mind is as below but not sure how to check if the workbook has already been created:

Sub Move()

lr = [a1].CurrentRegion.Rows.Count
For each color in Range("B3:B" & lr)
Workbooks.Add.SaveAs FileName:= color

Workbooks("raw.xlsx").Activate
With [a1].CurrentRegion
.AutoFilter 2, color
.Copy Workbooks(color).Sheets(1).[a1]
.AutoFilter
End With

Workbooks(color).Close True

Next color

End Sub

The problem with my code is that it would create duplicated workbooks such as the Red.xlsx twice in the example. Any advice on how to fix the problem or a totally different approach of achieving the same result will be much appreciated!

Chris Strickland · Accepted Answer · 2021-08-22 17:45:19Z

1

You can check for the existence of a file with

DIR("path\to\file.ext")

DIR returns TRUE if it exists, and FALSE if it does not.

You can also dedupe the results using UNIQUE:

For each c in Application.Unique(Range("B3:B" & lr))
    Debug.Print c
    Next

I used c here because color is already used by Excel. My VBA threw an error, but even if yours doesn't, you should avoid using variable names that already have a meaning in the language.

edited Aug 22, 2021 at 17:45

answered Aug 21, 2021 at 3:48

Chris Strickland

3,5101 gold badge20 silver badges18 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

JackeyOL Over a year ago

Thank you for your answer. The DIR approach definitely works. I'm curious about your 2nd approach. I'm not sure if I see the use of "Unique" in your code block. Could you please explain a bit more on how I can use it?

Chris Strickland Over a year ago

haha, it's because I left it out, maybe I copied that line out of your code instead of mine. Check that.

Chris Strickland Over a year ago

Does my edit work for you? It should return the unique values from the range.

VBasic2008 · Accepted Answer · 2021-08-23 17:44:33Z

Backup to Workbooks

Option Explicit

Sub BackupToWorkbooks()
    
    Const dPath As String = "C:\Test"
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    Const sfRow As Long = 2 ' Header Row
    Const scCol As Long = 2 ' Color Column
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    Dim rg As Range: Set rg = sws.Range(sFirst).CurrentRegion
    Dim strg As Range
    Set strg = rg.Resize(rg.Rows.Count - sfRow + 1).Offset(sfRow - 1)
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    Dim scrg As Range: Set scrg = sdrg.Columns(scCol)
    
    Dim cData As Variant: cData = ArrUniqueColumnRange(scrg)
    Dim tAddress As String: tAddress = strg.Address
    Dim cAddress As String: cAddress = scrg.Address

    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dtrg As Range
    Dim dcrg As Range
    Dim drg As Range
    Dim n As Long
    Dim dName As String
    For n = 0 To UBound(cData)
        sws.Copy
        Set dwb = ActiveWorkbook
        Set dws = dwb.Worksheets(1)
        Set dtrg = dws.Range(tAddress)
        dName = cData(n)
        dtrg.AutoFilter scCol, "<>" & dName
        If Application.Subtotal(103, dtrg.Columns(scCol)) > 1 Then
            Set dcrg = dws.Range(cAddress)
            Set drg = dcrg.SpecialCells(xlCellTypeVisible).EntireRow
            drg.Delete
        End If
        dws.AutoFilterMode = False
        Application.DisplayAlerts = False
        dwb.SaveAs dPath & "\" & dName & ".xlsx", xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next n

    Application.ScreenUpdating = True

    MsgBox "Color worksheets backed up.", vbInformation, "Backup To Workbooks"

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from the first column of a range,
'               in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueColumnRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    Dim Data As Variant
    Dim rCount As Long
    
    With rg.Columns(1)
        rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim r As Long
        For r = 1 To rCount
            Key = Data(r, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = Empty
                End If
            End If
        Next r
        If .Count = 0 Then Exit Function ' only error values and/or blanks
        ArrUniqueColumnRange = .Keys
    End With

End Function

Collectives™ on Stack Overflow

Create a new Workbook for each unique row in Excel VBA

2 Answers 2

3 Comments

Backup to Workbooks

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

3 Comments

Backup to Workbooks

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related