VBA Copy and Paste to new sheet based on validating date

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

My advice would be to use the macro recorder to summarize the sheet or range after the above code has done it's job. And then incorporate the recorded macro code into the above code to do it automatically each time. — John Muggins, May 24 '17 at 19:30
Thanks John. The recorder just shows the selection.copy, it doesn't use the category in I21:I44 to validate against what is copied. The 21 rows in range B21:AH44 contain data along with dollar amounts. When the macro is run, in this instance the 21 rows Total the dollars per category and paste in a separate worksheet. My 21 rows condenses to 3 based on the category and technically date of the order in this example. — Justin, May 24 '17 at 19:48
I should have referenced the original post for more information as well. https://stackoverflow.com/questions/37555692/vba-to-copy-and-paste-based-on-filter/37555842?noredirect=1#comment75336221_37555842 — Justin, May 24 '17 at 19:50
Just a general comment... `Sheets("NEW PO").Range("G21:G44") = Sheets("NEW PO").Range("I21:I44").Value2` will be a lot faster than the copy paste and accomplish the same thing. — MattD, May 24 '17 at 20:17
@MattD thank you, will update and test. Appreciate the input! — Justin, May 24 '17 at 20:42
Another thing, the line `Dim CatRng, MonthRng, SDate, CxlDate, PoNumb, Vendor, Description As Range` is actually initializing all but "Description" as variants. When you put multiple declarations on the same line, each one has to have an `as (type)` e.g. `Dim CatRng As Range, MonthRng As Range, SDate As Range, ...` — MattD, May 25 '17 at 11:29
Thanks Matt, I made that change as well, same result when the macro runs. I will upload the two worksheets, may make it easier to see what is going on. — Justin, May 25 '17 at 11:36
The result is the same because once you set them equal to a range, the variant becomes type Variant/Object/Range — MattD, May 25 '17 at 11:49

MattD · Answer 1 · 2017-05-25T17:30:22.053

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"

edited May 25 '17 at 17:30

answered May 25 '17 at 11:46

MattD

150
11

Matt, I've cut the workbook down to the necessary tabs and entered the necessary data on the NEW PO Tab. If you run the macro on the NEW PO tab called "Copy Data to PO" you will see how the "order" is consolidated. Currently I get no errors or type mismatch. https://www.dropbox.com/s/l2ikw6cr0rqzde8/Inventory%20Plan%20Sample.xlsm?dl=0 – Justin May 25 '17 at 12:12
Unfortunately, just about all online cloud storage providers are blocked at work and my internet facing machine runs linux so I can't download or run your code. Can you attach some screen shots? – MattD May 25 '17 at 12:45
I think you are not getting a type mismatch because the if statement is never true because you are looking at the .text property of cell. On my test code I set Count = 2 and had the number 2 entered in Cell C22. When stepping through the code, `If cell.Text = Count` evaluates to `If "2" = 2` which on my machine evaluates as False. If I use cell.Value, it evaluates as true and then the `Dsc = Dsc + ...` line causes run-time error 13 (type mismatch) – MattD May 25 '17 at 12:51
Top step through your code, in the VBA editor, click somewhere in the Copy_Data() sub and press F8. Keep pressing F8 to step through your code line-by-line. Highlight a variable or expression, then right click and "Add Watch..." to watch how the value changes as you step through the code. – MattD May 25 '17 at 12:54
Just added screen captures of the NEW PO Tab, PO tab, and a PO tab after the macro runs. I will go through your other comments as well. – Justin May 25 '17 at 13:24
when i step through the code I see the error message, as you pointed out. The resulting value that is copied shows as: : Value2 : "SS Ecotec Solid" : Variant/String : Module6.Copy_Data – Justin May 25 '17 at 13:39
Just had a minute to look at your screenshot, C21:C44 are strings so they can't be summed (I probably misunderstood your original question). Are you looking to count them instead? Remove duplicates? Can you explain what you mean by "summarize range C21:C44"? – MattD May 25 '17 at 14:35
They should be counted with duplicates removed. In the screen capture the PO Tab with the macro ran, column H should have returned 4 results now rather than 3. SS Ecotec Solid, SS Ecotec Stripe, LS Ladies Windjacket, Peached Ecotec Layer. Column H used to point to the New PO tab Y16 which had the same information each time (It always said Solid Shirt for example). Now that I am attempting to change what information is pulled to the PO tab, the copy macro really has another level of validation that needs to occur (the data in C21:C44) – Justin May 25 '17 at 14:48
I'll try and update the answer with more info later today but to get you started, what I would do is read your source data in to an array (see http://www.cpearson.com/excel/ArraysAndRanges.aspx) and then use code from this answer (https://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array) to strip duplicates and refer back to the Chip Pearson article to write the array back to the new range. – MattD May 25 '17 at 15:10
Answer updated. Hopefully that is more along the lines of what you are looking for. – MattD May 25 '17 at 17:14
I'm getting a Next without For compile error with the "Next Count" at the very end of the Sub. Any thoughts? – Justin May 25 '17 at 17:37
You probably have an extra Next floating around somewhere higher in the code. Count your number of For's and Next's to make sure they are the same. – MattD May 25 '17 at 18:06
Ok no more error messages but the same result. Column H on the PO tab returns 3 rows of "SS Ecotec Solid" – Justin May 25 '17 at 18:24
So you want to read C21:C44 on "New PO" and dump that in Column H of the "PO" tab with duplicates removed? – MattD May 25 '17 at 18:31
That is correct, however it needs to match the category coming from G21:G44 on the new PO tab. Its not exactly dumping unique values, its matching the category. In the screen capture of the New PO tab rows 21 through 25 would return 1 result with the description Ecotec Solid, category 1, quantity 30 and Total (dollars) $825. Back to my original code, or your revised which works. It seems like the only thing missing is a way to match or compare the Dsc against the Catrng – Justin May 25 '17 at 18:53
What is in G21:G44? It is hidden in the screen shot. – MattD May 25 '17 at 19:11
Its exactly what is in I21:I44 but in text format so it can transfer to the PO tab correctly. The users of the document wanted to be able to type in the sub category so I made "I" the data entry where G is what is actually being copied. – Justin May 25 '17 at 19:14
I don't have time to go through Glitch_Doctor's code to see what's going on but if you're getting 3 rows of the same thing instead of 3 different rows, you might need to use `Application.Transpose` on `.Range("H" & PORow).Value =Dsc` -> `.Range("H" & PORow).Value =Application.Transpose(Dsc)`flip the Dsc array from horizontal to vertical. – MattD May 25 '17 at 19:35
Thanks Matt. Good thought but still the same result. The code seems to only be capturing one value from the C21:C44 range regardless. Appreciate your input and assistance! – Justin May 25 '17 at 19:54
Best advice I can give is setup a watch for every variable and expression of interest and just step through the code watching how everything changes to see where the code goes wrong. Might also put a comment on https://stackoverflow.com/questions/37555692/vba-to-copy-and-paste-based-on-filter with a link to this question to tie the two together. – MattD May 25 '17 at 20:06
Thanks Matt. Not a complete resolution yet but I set DSC as a string and changed the Catrng code to include `Dsc = Dsc + Sheets("NEW PO").Range("C" & Row).Value`. Returns multiple descriptions on the PO tab. Not "consolidated" yet but a closer result – Justin May 25 '17 at 20:40

score 1 · Answer 2 · answered May 25 '17 at 20:58

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

VBA Copy and Paste to new sheet based on validating date

2 Answers2