Excel宏复制包含当前数组值的所有单元格并将其粘贴到新工作簿中

Question

我得到了一个电子表格，其中包含C列中的家具供应商列表。其他列包含有关他们所库存的不同家具产品的信息。 我的任务是为每个供应商复制包含有关这些家具产品信息的所有单元格，并将它们粘贴到新的工作簿中。 大约有66个不同的供应商，因此显然我不愿意手动进行此操作。 我以为这里的某人将不得不完成类似的任务，并且可能知道如何编写宏来解决该问题。

到目前为止，我已经设法编写了以下代码。 它基本上需要用户选择，并遍历选择中的所有单元。 获取唯一值（每个新家具供应商），并将它们添加到仅包含唯一值的数组中。 我遇到的问题是确定下一步该怎么做。

Sub addItemsToArray()
    Dim varIn As Variant 'User Selection
    Dim varUnique As Variant 'Array containing Unique Values
    Dim iInRow As Long 'Variable storing current row number
    Dim iUnique As Long 'Variable storing current unqiue array value
    Dim nUnique As Long 'Variable storing number of unique values in User Selection.
    Dim isUnique As Boolean 'Boolean Variable indicating whether current value is unique or not
    Dim sValue As Long 'I have included these two values to find start and end position for unique                 values in user Selection
    Dim lValue As Long

    varIn = Selection

    ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2)) 'Set upper and lower bounds for VarUnique array, lower bound will be 1, upper will be last cell in selection

    nUnique = 0 'Number of Unique values set as 0 by default

    'Looping through all Values in User Selection
    For iInRow = LBound(varIn, 1) To UBound(varIn, 1)

            isUnique = True 'First value will always be unique so set isUnique to True

            'Loop through from 1 to the Number of Unique Values in Array. Set to 0 by default.
            'If CurrentCell Value is equal to element in array then it is not Unique, as such isUnique will be set to False and For loop will be exited.
            For iUnique = 1 To nUnique
                If varIn(iInRow, 1) = varUnique(iUnique) Then
                    isUnique = False
                    Exit For
                End If
            Next iUnique


            If isUnique = True Then
                sValue = lValue
                nUnique = nUnique + 1
                varUnique(nUnique) = varIn(iInRow, 1)
                lValue = iInRow
            End If
    Next iInRow
    '// varUnique now contains only the unique values.
    '// Trim off the empty elements:
    ReDim Preserve varUnique(1 To nUnique)
End Sub

如果有人能帮助我指出正确的方向，我将非常感激。

我在下面提供了工作表的图像。 如您所见，列C包含供应商列表。 我需要做的是，复制每个供应商的所有单元格，将这些单元格放在新的工作表中并保存，并将供应商的名称作为文件名。 我希望这使它更加清楚。

Answer 1

Sub Parse_Furniture_Suppliers()
    Dim tmpCell As Range, rngHeaders As Range, rngTarget As Range

    Set rngHeaders = ActiveSheet.Range("A1:F1")
    Set tmpCell = ActiveSheet.Range("C2")

    Workbooks.Add
    ActiveSheet.Range("A1:F1").Value = rngHeaders.Value
    Set rngTarget = ActiveSheet.Range("A2")
    rngTarget.Select
    ActiveWindow.FreezePanes = True
    rngTarget.Resize(1, 6).Value = tmpCell.Offset(0, -2).Resize(1, 6).Value
    Set rngTarget = rngTarget.Offset(1)
    Set tmpCell = tmpCell.Offset(1)

    Do While tmpCell.Value <> ""
        If tmpCell.Value <> tmpCell.Offset(-1).Value Then
            ActiveWorkbook.SaveAs tmpCell.Offset(-1).Value
            ActiveWorkbook.Close
            Workbooks.Add
            ActiveSheet.Range("A1:F1").Value = rngHeaders.Value
            Set rngTarget = ActiveSheet.Range("A2")
            rngTarget.Select
            ActiveWindow.FreezePanes = True
        End If

        rngTarget.Resize(1, 6).Value = tmpCell.Offset(0, -2).Resize(1, 6).Value
        Set rngTarget = rngTarget.Offset(1)
        Set tmpCell = tmpCell.Offset(1)
    Loop

    ActiveWorkbook.SaveAs tmpCell.Offset(-1).Value
    ActiveWorkbook.Close
End Sub