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

Question

I am trying to modify the VBA @Glitch_Doctor worked with me on. The "Description" range has changed on the New PO tab and needs to summarize in text form on the PO tab. I have all working currently it copies text to the appropriate column and row but does not summarize what is in the range C21:C44. Appreciate anyone's help getting the new data to summarize based on category and date, which it is not currently doing.

This is the new items added to the code:

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

This is the full 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

Link to the working file: https://www.dropbox.com/s/l2ikw6cr0rqzde8/Inventory%20Plan%20Sample.xlsm?dl=0

Screen Capture with New PO tab, PO Tab, PO tab after macro runs Screen Capture of Tabs

Answer 1

If you are looking to count unique values in C21:C44 per your earlier comment then the code examples here ( Count unique values in Excel ) should work for you.

I tested this answer ( https://stackoverflow.com/a/36083024/7612553 ) and it works. I added And cell.Value <> "" so it would not count blank cells passed to the function.

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

Then you could replace the For Each cell In Description loop with a call to CountUnique(Description)

For the scripting dictionary to work, you need to add a reference to Microsoft Scripting Runtime: Tools > References... > check "Microsoft Scripting Runtime"

Answer 2

I believe this solved the question. Converted Dsc to a string and incorporated it into the Catrng array. The missing link was Dsc="" to reset the value each time the array returned

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