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

Question

如图所示，我有原始数据（A2:C6），我想根据B列中的每个唯一值创建一个新工作簿。在该示例中，“颜色”列中有4种颜色和3种唯一颜色，因此我将创建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

我的代码的问题是，它会创建重复的工作簿，如红色。在本例中，xlsx两次。对于如何解决问题或采用完全不同的方法来实现相同的结果，我们将不胜感激！

Answer 1

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

Answer 2

您可以使用检查文件是否存在

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抛出了错误，但即使您的没有，您也应该避免使用在语言中已经有含义的变量名。