Originally Posted by
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.
[vba]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
[/vba]