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