VBA根据validationdate复制并粘贴到新工作表
我正在尝试修改与我合作的VBA @Glitch_Doctor。 “新build采购订单”选项卡上的“描述”范围已更改，需要在“采购订单”选项卡上以文本forms进行汇总。 我目前所有的工作都将文本复制到适当的列和行，但不总结范围C21：C44中的内容。 感谢任何人根据类别和date获取新数据进行汇总，这是目前没有做的事情。
这是添加到代码中的新项目：
Dim Dsc As Variant Dsc = Sheets("New PO").Range("C21:C44") For Each cell In Description 'To get the row number then total the required information If cell.Text = Count Then Row = cell.Row Dsc = Dsc + Sheets("NEW PO").Range("C21:C44" & Row).Text End If Next cell 这是完整的VBA：
Sub Copy_Data() Dim Count, Qty As Long Dim CatRng, MonthRng, SDate, CxlDate, PoNumb, Vendor, Description As Range Dim Total As Currency Dim StrTarget As String Dim Dsc As Variant Dim Row, PORow, Col As Integer With Sheets("NEW PO").Range("I21:I44").Copy End With With Sheets("NEW PO").Range("G21:G44") .PasteSpecial xlPasteValues, , False, False End With Range("A1").Select Application.CutCopyMode = False Set CatRng = Sheets("NEW PO").Range("G21:G44") Set MonthRng = Sheets("POs").Range("M122:X122") StrTarget = Sheets("New PO").Range("W12") Set SDate = Sheets("New PO").Range("U12") Set CxlDate = Sheets("New PO").Range("U13") Set PoNumb = Sheets("New PO").Range("N10") Set Vendor = Sheets("New PO").Range("D14") Set Description = Sheets("New PO").Range("C21:C44") Dsc = Sheets("New PO").Range("C21:C44") Count = 0 For Count = 0 To 99 Total = 0 Qty = 0 'So that the values reset each time the cat changes For Each cell In CatRng 'To get the row number then total the required information If cell.Value = Count Then Row = cell.Row Qty = Qty + Sheets("NEW PO").Range("T" & Row).Value Total = Total + Sheets("NEW PO").Range("AA" & Row).Value 'I guessed ext cost only as it has been totaled at the bottom, 'this is easily changed though End If Next cell For Each cell In Description 'To get the row number then total the required information If cell.Text = Count Then Row = cell.Row Dsc = Dsc + Sheets("NEW PO").Range("C21:C44" & Row).Text End If Next cell 'Now put the totals into a PO only if there is a quantity of items If Qty > 0 Then PORow = Sheets("POs").Range("L1048576").End(xlUp).Row + 1 'I'll let you sort the PO number and other fields out but the main 3 are done below With Sheets("POs") .Range("I" & PORow).Value = Qty .Range("L" & PORow).Value = Count .Range("C" & PORow).Value = SDate .Range("D" & PORow).Value = CxlDate .Range("B" & PORow).Value = PoNumb .Range("F" & PORow).Value = Vendor .Range("H" & PORow).Value = Dsc 'My understanding here is that the target month in U12 is in the same format as 'the anticipated Receipt month, I hope this is what you were looking for For Each cell In MonthRng If cell.Value = StrTarget Then Col = cell.Column .Cells(PORow, Col).Value = Total 'Used .cells here as both column and row are now integers '(only way i can ever get it to work) End If Next cell End With End If Next Count End Sub
链接到工作文件： https ： //www.dropbox.com/s/l2ikw6cr0rqzde8/Inventory%20Plan%20Sample.xlsm？dl = 0
使用新的PO选项卡，PO选项卡，macros观运行后的PO选项卡的屏幕捕获屏幕截图
如果您正在计算C21：C44中每个先前评论的唯一值，那么这里的代码示例（ 在Excel中计算唯一值 ）应该适合您。
我testing了这个答案（ https://stackoverflow.com/a/36083024/7612553 ），它的工作原理。 我添加And cell.Value <> ""所以它不会计算传递给函数的空白单元格。
Public Function CountUnique(rng As Range) As Long Dim dict As Scripting.Dictionary Dim cell As Range Set dict = New Scripting.Dictionary For Each cell In rng.Cells If Not dict.Exists(cell.Value) And cell.Value <> "" Then dict.Add cell.Value, 0 End If Next CountUnique = dict.Count End Function
然后，您可以用“调用CountUnique(Description)来replace“ For Each cell In Description CountUnique(Description)循环中的“
要使脚本字典正常工作，需要添加对Microsoft脚本运行时的引用：工具>引用…>选中“Microsoft Scripting Runtime”
我相信这解决了这个问题。 将Dsc转换为string并将其合并到Catrng数组中。 缺less的链接是Dsc=""每当数组返回时重置该值
Sub Copy_Data() Dim Count As Long Dim Qty As Long Dim CatRng As Range Dim MonthRng As Range Dim SDate As Range Dim CxlDate As Range Dim PoNumb As Range Dim Vendor As Range Dim Description As Range Dim Total As Currency Dim StrTarget As String Dim Dsc As String Dim Row As Integer Dim PORow As Integer Dim Col As Integer With Sheets("NEW PO").Range("I21:I44").Copy End With With Sheets("NEW PO").Range("G21:G44") .PasteSpecial xlPasteValues, , False, False End With Range("A1").Select Application.CutCopyMode = False Set CatRng = Sheets("NEW PO").Range("G21:G44") Set MonthRng = Sheets("POs").Range("M122:X122") StrTarget = Sheets("New PO").Range("W12") Set SDate = Sheets("New PO").Range("U12") Set CxlDate = Sheets("New PO").Range("U13") Set PoNumb = Sheets("New PO").Range("N10") Set Vendor = Sheets("New PO").Range("D14") Set Description = Sheets("New PO").Range("C21:C44") Count = 0 For Count = 0 To 99 Total = 0 Qty = 0 Dsc = "" 'So that the values reset each time the cat changes For Each cell In CatRng 'To get the row number then total the required information If cell.Value = Count Then Row = cell.Row Qty = Qty + Sheets("NEW PO").Range("T" & Row).Value Total = Total + Sheets("NEW PO").Range("AA" & Row).Value Dsc = Sheets("NEW PO").Range("C" & Row).Value 'I guessed ext cost only as it has been totaled at the bottom, 'this is easily changed though End If Next cell 'Now put the totals into a PO only if there is a quantity of items If Qty > 0 Then PORow = Sheets("POs").Range("L1048576").End(xlUp).Row + 1 'I'll let you sort the PO number and other fields out but the main 3 are done below With Sheets("POs") .Range("I" & PORow).Value = Qty .Range("L" & PORow).Value = Count .Range("C" & PORow).Value = SDate .Range("D" & PORow).Value = CxlDate .Range("B" & PORow).Value = PoNumb .Range("F" & PORow).Value = Vendor .Range("H" & PORow).Value = Dsc 'My understanding here is that the target month in U12 is in the same format as 'the anticipated Receipt month, I hope this is what you were looking for For Each cell In MonthRng If cell.Value = StrTarget Then Col = cell.Column .Cells(PORow, Col).Value = Total 'Used .cells here as both column and row are now integers '(only way i can ever get it to work) End If Next cell End With End If Next Count End Sub