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

Question

I've been given a spreadsheet that contains a list of furniture suppliers in Column C. The other columns contain information about the different furniture products they stock. My task is to copy all the cells containing information about those furniture products for each supplier and paste them into a new workbook. There are around 66 different suppliers so obviously I don't really fancy doing this manually. I thought someone here would have had to have done a similar task and might know how I could go about writing a Macro to solve the problem.

So far I've managed to write the following code. It basically takes the users selection, loops through all the Cells in the selection. Takes the unique values (each new furniture supplier) and adds them to an array containing only the unique values. The problem I'm having is working out what to do next.

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

If anyone could help point me in the right direction I would very much appreciate it.

I've included an image of the worksheet below. As you can see Column C contains the list of suppliers. What I need to do is, copy all cells for each supplier, place those cells in a new worksheet and save it, with the name of the supplier as the file name. I hope that's made it a bit clearer.

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