I Need a Macro to Sort out a Large Database . . .

[WillRn]

I have a delimma.

I have downloaded a large database that I need to sort according to medical
record number. The data comes in the following form:

Col A Col B Col C . . . Col P
Acct # MR # Dr ID # . Data Item(s)
001 123 # . . . abc
002 123 # . . . .abc
003 125 # . . . .abc
004 125 # . . . abc
005 125 # . . . abc

All of the account numbers are different and refer to each patient visit.
All of the Medical Record Numbers are unique to the patient and do not
change. The list is sorted by account number and by date. I need to, by MR#
(if they match), take the next account number and move it the right of the
matching MR#'s data above it. If the next medical number does not match, I
need to go to the next line and move the following data by MR number. The
list, when sorted, would look like:

Col A Col B Col C . . . Col P Col Q Col R Col S . . .
Col P Col Q . .
Acct # MR # Dr ID # . Item(s) Acct # MR # Dr ID # . Item(s)
Acct#
001 123 # . . . abc 002 123 # .
.. . .abc -- . . .
003 125 # . . . .abc 004 125 # .
.. . abc 005 . . .

Sometimes the MR# can be repeated up to 5 times with different account
numbers for all MR#. Luckily each set of account numbers is grouped together
by MR Number, so a "For Each I, next I" would work well. It's the matching
numbers and deleting the empty lines that has my brain all confused.

If anybody has already tackled a similar problem, I would love to see how
you did it.

Thanks again for all the help you guys give me.

WillRn

 

[Dave Peterson]

This creates a new worksheet--so it shouldn't harm anything if it's not right
<vbg>.

It does expect your data to be sorted by column B, though.

Option Explicit
Sub testme()

Dim curWks As Worksheet
Dim newWks As Worksheet
Dim iCtr As Long
Dim iRow As Long
Dim oRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim DupCtr As Long
Dim ColsPerGroup As Long

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

oRow = 1
With curWks

'too lazy to count from A to P!
ColsPerGroup = .Range("P1").Column - .Range("A1").Column + 1

FirstRow = 2 'headers in row 1?
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

DupCtr = 0
For iRow = FirstRow To LastRow
If .Cells(iRow, "B").Value = .Cells(iRow - 1, "B").Value Then
DupCtr = DupCtr + 1
Else
DupCtr = 0
oRow = oRow + 1
End If
newWks.Cells(oRow, DupCtr * ColsPerGroup + 1) _
.Resize(1, ColsPerGroup).Value _
= .Cells(iRow, "A").Resize(1, ColsPerGroup).Value
Next iRow
End With
End Sub

 

[WillRn]

Worked Great!

You just saved me a ton of time sorting manually!

Thanks again!

WillRn