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

我已经收到了一个电子表格，其中包含C列中的家具供应商列表。其他列包含有关他们所存储的不同家具产品的信息。 我的任务是复制包含每个供应商家具产品信息的所有单元格，并将其粘贴到新的工作簿中。 有大约66个不同的供应商，所以显然我并不喜欢手动做这个。 我以为这里的某个人不得不做了类似的工作，并且可能知道如何去写一个macros来解决这个问题。

到目前为止，我已经设法写下面的代码。 它基本上是用户select，循环select中的所有单元格。 采取独特的价值观（每个新的家具供应商），并将其添加到只包含唯一值的数组中。 我遇到的问题是下一步做什么。

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