Help with macro to combine like rows

[mrtrick8586]

I'm trying to combine like rows into one row. I've attached a sample and I've tried cooking up a macro to even help with my efforts, but alas cannot figure it out. My knowledge of macros is limited and any help would be appreciated.

As you can see from the sample, I'm trying to combine groups into a new worksheet so that I can use that data to create a calendar of what our employees have done for that month.

If you have any questions, please let me know.

[mdmackillop]

Welcome to VBAX
How about a SumProduct solution

[mrtrick8586]

Thanks! I'll look into this and see how well it applies to the rest of the data I have.


Welcome to VBAX
How about a SumProduct solution

[mrtrick8586]

Thanks for the help, but how would I use this function so that it condenses what is is in the sample data worksheet down into one line that is then output into another worksheet? Can you help me out with working with this function?


Welcome to VBAX
How about a SumProduct solution

[mdmackillop]

This would be simplified if the dates column were all set to the first of the month. This would allow a filter to produce unique records. Can that be achieved or do the date values matter.

[mrtrick8586]

The only dates that matter are the month and the service dates that are lined up to the right as column headings. So yes, the month/year date can be changed to the first of the month if need be.

Just a little more info about my project. I thought a macro would be the best route, because I have about 4000 entries that need to be condensed. However, if there is a better way to display the info for my purpose then I'd be willing to change things around. I ultimately want to use the consolidated data in a word form, for record keeping purposes, and so I can save trees and don't print 4000 pages of information.

Any other questions, just let me know.

[mdmackillop]

This works OK on the data supplied but may take time with 4000 rows. The code relies on several dynamic range names contained within the sample workbook and the layout provided.

Option Explicit
Sub Filter()
Dim Rws As Long
Rws = Range("target").CurrentRegion.Rows.Count - 2
If Rws > 0 Then Range("target").Offset(1).Resize(Rws, 40).ClearContents
Call FixDates(Range("Visit"))
Range("Data").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Target").Resize(, 4), Unique:=True
With Range("target")
Rws = .CurrentRegion.Rows.Count - 2
.Offset(1, 4).Resize(Rws, 31).FormulaR1C1 = _
"=SUMPRODUCT(--(Patient=RC1),--(Therapist=RC2),--(Visit=RC3),--(Service=RC4),(OFFSET(Patient,0,R2C+3)))"
End With
End Sub

Sub FixDates(Rng)
Dim cel As Range
For Each cel In Rng
cel.Value = DateSerial(Year(cel), Month(cel), 1)
Next
End Sub

[mrtrick8586]

Thank you so much. It appears to work beautifully and it only took about 30-40 seconds to work its magic on the 3000 rows. I'm just spot checking to see if there were any errors and it doesn't look like there are. Thanks again.:bow:


This works OK on the data supplied but may take time with 4000 rows. The code relies on several dynamic range names contained within the sample workbook and the layout provided.

Option Explicit
Sub Filter()
Dim Rws As Long
Rws = Range("target").CurrentRegion.Rows.Count - 2
If Rws > 0 Then Range("target").Offset(1).Resize(Rws, 40).ClearContents
Call FixDates(Range("Visit"))
Range("Data").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Target").Resize(, 4), Unique:=True
With Range("target")
Rws = .CurrentRegion.Rows.Count - 2
.Offset(1, 4).Resize(Rws, 31).FormulaR1C1 = _
"=SUMPRODUCT(--(Patient=RC1),--(Therapist=RC2),--(Visit=RC3),--(Service=RC4),(OFFSET(Patient,0,R2C+3)))"
End With
End Sub

Sub FixDates(Rng)
Dim cel As Range
For Each cel In Rng
cel.Value = DateSerial(Year(cel), Month(cel), 1)
Next
End Sub

[mdmackillop]

SumProduct in such sheets takes a lot of calculation. You may want to copy/pastespecial values unless it need to be constantly updated. In such sheets I would do this, reserving the formula only in the top row. You can then easily copy down the formulae if a refresh is required.