VBA根据验证日期复制并粘贴到新工作表

Question

我正在尝试修改VBA @Glitch_Doctor与我一起工作。 ＆＃34;描述＆＃34;范围在新建选项卡选项卡上已更改，需要在采购订单选项卡上以文本形式汇总。我现在都在工作，它将文本复制到适当的列和行，但不总结C21：C44范围内的内容。感谢任何人根据类别和日期对新数据进行总结的帮助。

这是添加到代码中的新项目：

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选项卡，PO选项卡进行屏幕捕获 Screen Capture of Tabs

Answer 1

如果您希望根据之前的评论计算C21：C44中的唯一值，那么此处的代码示例（Count unique values in Excel）应该适合您。

我测试了这个答案（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

然后，您可以通过调用For Each cell In Description

来替换CountUnique(Description)循环

要使脚本字典起作用，您需要添加对Microsoft Scripting Runtime的引用：工具＆gt;参考文献...＆gt;检查“Microsoft Scripting Runtime”

Answer 2

我相信这解决了这个问题。将Dsc转换为字符串并将其合并到Catrng数组中。缺少的链接是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