trying to get column values to line up...

W

Whitney

I have a problem that seems like there should be an easy answer... but
i just can't figure it out... there might not be answer...

The situation:

In column A all of my company's employee numbers are listed (about
3000).

In column B, all of the employee numbers are listed again... however
they repeat depending on the number of degrees that employee has. For
instance, an employee will have 2 rows in column B if they have a BA
and an MS.

Column B, therefore, has about 8,000 rows.

What I would like to have is the employee number in column A line up
with the first instance of that same employee number in column B.
Blank cells would somehow "appear" in column A so that the values in
column A line up accordingly with the values in column B.

Is this even possible without a TON of manual insertion?
 
D

Dave Peterson

And if an employee doesn't have a degree, then they won't have an appearance in
column B?

And I wasn't sure if you actually had the degrees in column C, D,... If you do,
then change this line:
myCols = 2
to the number of columns that need to be sorted with B
(B:D would become myCols = 3)

Option Explicit
Sub testme()

Application.ScreenUpdating = False

Dim wks As Worksheet
Dim ColA As Range
Dim ColB As Range
Dim iRow As Long
Dim myCols As Long

Set wks = Worksheets("sheet1")
wks.DisplayPageBreaks = False
With wks
'row 1 has headers!
Set ColA = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
Set ColB = .Range("b2", .Cells(.Rows.Count, "B").End(xlUp))

With ColA
.Sort key1:=.Cells(1), order1:=xlAscending, header:=xlNo
End With

'change the mycols to the number of columns that
'are associated with column B

myCols = 2 ' columns B:C
With ColB.Resize(, myCols)
.Sort key1:=.Cells(1), order1:=xlAscending, header:=xlNo
End With

iRow = 2
Do
If Application.CountA(.Cells(iRow, "A").Resize(1, 2)) = 0 Then
Exit Do
End If

If .Cells(iRow, "A").Value = .Cells(iRow, "B").Value _
Or Application.CountA(.Cells(iRow, "A").Resize(1, 2)) = 1 Then
'do nothing
Else
If .Cells(iRow, "A").Value > .Cells(iRow, "B").Value Then
.Cells(iRow, "A").Insert shift:=xlDown
Else
.Cells(iRow, "B").Resize(1, myCols).Insert shift:=xlDown
End If
End If
iRow = iRow + 1
Loop
End With

Application.ScreenUpdating = True

End Sub
 
Top