为 Excel VBA 中的每个唯一行创建一个新工作簿

Question

如图所示，我有原始数据 (A2:C6)，我想根据 B 列中的每个唯一值创建一个新工作簿。在示例中，“颜色”列中有 4 个 colors 和 3 个唯一值colors，因此我将创建 3 个不同的新工作簿（Red.xlsx、Yellow.xlsx 和 Orange.xlsx），如图底部所示。

所以我想到的代码如下但不确定如何检查工作簿是否已经创建：

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

我的代码的问题是它会在示例中两次创建重复的工作簿，例如 Red.xlsx。 任何关于如何解决问题的建议或实现相同结果的完全不同的方法将不胜感激！

Answer 1

您可以检查文件是否存在

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

DIR 如果存在则返回 TRUE，如果不存在则返回 FALSE。

您还可以使用 UNIQUE 对结果进行重复数据删除：

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

我在这里使用c因为color已经被 Excel 使用。我的 VBA 抛出了一个错误，但即使你的没有，你也应该避免使用已经在语言中具有意义的变量名。

Answer 2

备份到工作簿

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