Vba Excel宏复制包含当前数组值的所有单元格并将其粘贴到新工作簿
我收到了一份电子表格,其中包含C列中的家具供应商列表。其他列包含他们库存的不同家具产品的信息。我的任务是复制包含每个供应商家具产品信息的所有单元格,并将其粘贴到新工作簿中。大约有66家不同的供应商,所以很明显,我不太喜欢手工操作。我想这里的某个人也必须完成类似的任务,并且可能知道如何编写宏来解决这个问题 到目前为止,我已经成功地编写了以下代码。它基本上接受用户的选择,循环选择中的所有单元格。获取每个新家具供应商的唯一值,并将其添加到仅包含唯一值的数组中。我遇到的问题是想好下一步该做什么Vba Excel宏复制包含当前数组值的所有单元格并将其粘贴到新工作簿,vba,excel,copy-paste,Vba,Excel,Copy Paste,我收到了一份电子表格,其中包含C列中的家具供应商列表。其他列包含他们库存的不同家具产品的信息。我的任务是复制包含每个供应商家具产品信息的所有单元格,并将其粘贴到新工作簿中。大约有66家不同的供应商,所以很明显,我不太喜欢手工操作。我想这里的某个人也必须完成类似的任务,并且可能知道如何编写宏来解决这个问题 到目前为止,我已经成功地编写了以下代码。它基本上接受用户的选择,循环选择中的所有单元格。获取每个新家具供应商的唯一值,并将其添加到仅包含唯一值的数组中。我遇到的问题是想好下一步该做什么 Sub
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列包含供应商列表。我需要做的是,复制每个供应商的所有单元格,将这些单元格放在新的工作表中并保存,以供应商的名称作为文件名。我希望这能让事情更清楚一点。
不清楚您想做什么。如果您可以发布源工作表和目标工作表的示例,这将有所帮助。其他列包含他们库存的不同家具产品的信息。我的任务是复制包含每个供应商家具产品信息的所有单元格,并将其粘贴到新工作簿中。您需要提供更多详细信息,确切说明要复制哪些单元格,以及在给定C列中的最小值时如何确定这些单元格。是否新建工作表或工作簿?您最近的编辑似乎与您的标题和原始描述相矛盾。
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