Compare & align like items from 2 Roaster columns of Employees.

[u473]

Compare & align like items from 2 Roaster columns of Employees.
..
For instance :
Old in Column A New in Column B
Albert Albert
Bob Bob
Charles Dwight
Dwight Elmer
Frank Gus
..
Expected Result after VBA execution
Old in Column A New in Column B
Albert Albert
Bob Bob
Charles
Dwight Dwight
Elmer
Frank
Gus
..
The following solution given on this group is close to working,
but, it has a bug I have not been able to resolve in debug mode.
Namely, in the loop process, it finds Elmer, but either does not
write it or overwrites it.
In addition, I would like to see the syntax for Old Roaster coming
from Workbook A Sheet1
New Roaster from Workbook B Sheet1, and the result in Workbook C
Sheet1.
..
Sub LineEmUp()
Dim flag As Boolean
Dim MyRangeA As Range, MyRangeC As Range
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = lastrow To 2 Step -1
If IsEmpty(Cells(x - 1, 1)) Or IsEmpty(Cells(x, 1)) Then GoTo
getmeout
If Asc(UCase(Cells(x, 1))) - Asc(UCase(Cells(x - 1, 1))) > 1 Then
For p = 1 To (Asc(Cells(x, 1)) - Asc(Cells(x - 1, 1))) - 1
Rows(x).Select
Selection.Insert shift:=xlDown
Next
getmeout:
End If
Next
'sort B
Columns("B:B").Insert shift:=xlToRight
lastrowC = Cells(Rows.Count, "C").End(xlUp).Row
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
Set MyRangeC = Range("C1:C" & lastrowC)
Set MyRangeA = Range("A1:A" & lastrowA)
For Each c In MyRangeC
For Each a In MyRangeA
flag = True
If UCase(a.Value) = UCase(c.Value) Then
a.Offset(, 1).Value = c.Value
flag = False
Exit For
End If
Next
If flag = True Then
templast = Cells(Rows.Count, "B").End(xlUp).Row
Range("A" & templast + 1).Offset(, 1).Value = c.Value
flag = False
End If
Next
'Tidy Up
Columns("C:C").Delete shift:=xlToLeft
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
lastrowB = Cells(Rows.Count, "B").End(xlUp).Row
For x = WorksheetFunction.Max(lastrowA, lastrowB) To 1 Step -1
If IsEmpty(Cells(x, 1)) And IsEmpty(Cells(x, 2)) Then
Rows(x).EntireRow.Delete
End If
Next
End Sub
..
This case has many applications like in scheduling to detect either
new or dropped activities.
Thank you for your help.
J.P.

 

[Mike H]

Hi,

This solves the losing 'Elmer' problem but getting column B sorted in the
way you want?? let me think

Sub LineEmUp()
Dim flag As Boolean
Dim MyRangeA As Range, MyRangeC As Range
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = lastrow To 2 Step -1
If IsEmpty(Cells(x - 1, 1)) Or IsEmpty(Cells(x, 1)) Then GoTo getmeout
If Asc(UCase(Cells(x, 1))) - Asc(UCase(Cells(x - 1, 1))) > 1 Then
For p = 1 To (Asc(Cells(x, 1)) - Asc(Cells(x - 1, 1))) - 1
Rows(x).Select
Selection.Insert shift:=xlDown
Next
getmeout:
End If
Next
'sort B
Columns("B:B").Insert shift:=xlToRight
lastrowC = Cells(Rows.Count, "C").End(xlUp).Row
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
Set MyRangeC = Range("C1:C" & lastrowC)
Set MyRangeA = Range("A1:A" & lastrowA)
For Each c In MyRangeC
For Each a In MyRangeA
flag = True
If UCase(a.Value) = UCase(c.Value) Then
a.Offset(, 1).Value = c.Value
flag = False
Exit For
End If
Next
If flag = True Then
templastA = Cells(Rows.Count, "A").End(xlUp).Row
templastB = Cells(Rows.Count, "B").End(xlUp).Row
Range("A" & WorksheetFunction.Max(templastA, templastB) + 1).Offset(,
1).Value = c.Value
flag = False
End If
Next
'Tidy Up
Columns("C:C").Delete shift:=xlToLeft
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
lastrowB = Cells(Rows.Count, "B").End(xlUp).Row
For x = WorksheetFunction.Max(lastrowA, lastrowB) To 1 Step -1
If IsEmpty(Cells(x, 1)) And IsEmpty(Cells(x, 2)) Then
Rows(x).EntireRow.Delete
End If
Next
End Sub

 

[Joel]

The code you posted only compared first character of the names and wouldn't
of worked under all conditions. It was too hard to fix so I rewrote the code
in a much simplier method.

I combined all the names together in one list and then used advance filter
to create a unique list of names. Then I match each list in column A against
the master list to get the results.

I used extra columns to get the results so in the end I deleted these extra
rows and coluns. Advance filter has a problem that it create a duplicate
first entry in rows 1 and 2 so I had to work around this bug.


Sub CombineLists()

'Insert Blank row to get rid of Excel Error in Advance filter duplicating
'first entry
Rows(1).Insert

'1st get a unique list of names
'Make a combined list in columnC
'copy A to C
Columns("A").Copy Destination:=Columns("C")
LastRowB = Range("B" & Rows.Count).End(xlUp).Row
LastRowC = Range("C" & Rows.Count).End(xlUp).Row
'Copy Column B to End of Column C
Range("B2:B" & LastRowB).Copy _
Destination:=Range("C" & (LastRowC + 1))

'sort Row C
LastRowC = Range("C" & Rows.Count).End(xlUp).Row
Set sortRange = Range("C2:C" & LastRowC)
sortRange.Sort _
Key1:=Range("C1"), _
Order1:=xlAscending, _
Header:=xlNo
'Get Unique Records and place in Column D
sortRange.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("D1"), _
Unique:=True

'Put Data in from: column B and C to: E and F in the correct rows
For ColCount = 1 To 2
LastRow = Cells(Rows.Count, ColCount).End(xlUp).Row
For RowCount = 2 To LastRow
If Cells(RowCount, ColCount) <> "" Then
Person = Cells(RowCount, ColCount)
Set c = Columns("D").Find(what:=Person, _
LookIn:=xlValues, lookat:=xlWhole)
c.Offset(0, ColCount) = Person
End If
Next RowCount
Next ColCount

'Delete columns A to D
Columns("A").Delete
'Delete Row 1
Rows(1).Delete
End Sub

 

[u473]

Thank you very much, that was quite an education. I will put it to
test right away.
Last cherry on the cake, syntax wise, how do I refer to data in
separate workbooks.
Old Roaster from Workbook A , New Roaster from Workbook B , all using
sheet1 Col A,
and Result in Workbook C ,
Having originally all the data on the same sheet was only for the
convenience of this research.
Thank you again.
J.P.

 

[Joel]

the code below I simply opened two workbooks and copied the data to column A
and B like you original input. then ran the rest of the code unchanged. You
may need to change the worksheet names in the two workbooks that get opened.
I used Sheet1 in the code below.


Sub CombineLists()


filetoOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")
If filetoOpen = False Then
MsgBox "Cannot open file - Exiting Sub"
Exit Sub
End If

Set bk = Workbooks.Open(Filename:=filetoOpen)
bk.Sheets("Sheet1").Columns("A").Copy _
Destination:=ThisWorkbook.Sheets("Sheet1").Columns("A")
bk.Close

filetoOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")
If filetoOpen = False Then
MsgBox "Cannot open file - Exiting Sub"
Exit Sub
End If

Set bk = Workbooks.Open(Filename:=filetoOpen)
bk.Sheets("Sheet1").Columns("A").Copy _
Destination:=ThisWorkbook.Sheets("Sheet1").Columns("B")
bk.Close

'Insert Blank row to get rid of Excel Error in Advance filter duplicating
'first entry
Rows(1).Insert

'1st get a unique list of names
'Make a combined list in columnC
'copy A to C
Columns("A").Copy Destination:=Columns("C")
LastRowB = Range("B" & Rows.Count).End(xlUp).Row
LastRowC = Range("C" & Rows.Count).End(xlUp).Row
'Copy Column B to End of Column C
Range("B2:B" & LastRowB).Copy _
Destination:=Range("C" & (LastRowC + 1))

'sort Row C
LastRowC = Range("C" & Rows.Count).End(xlUp).Row
Set sortRange = Range("C2:C" & LastRowC)
sortRange.Sort _
Key1:=Range("C1"), _
Order1:=xlAscending, _
Header:=xlNo
'Get Unique Records and place in Column D
sortRange.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("D1"), _
Unique:=True

'Put Data in from: column B and C to: E and F in the correct rows
For ColCount = 1 To 2
LastRow = Cells(Rows.Count, ColCount).End(xlUp).Row
For RowCount = 2 To LastRow
If Cells(RowCount, ColCount) <> "" Then
Person = Cells(RowCount, ColCount)
Set c = Columns("D").Find(what:=Person, _
LookIn:=xlValues, lookat:=xlWhole)
c.Offset(0, ColCount) = Person
End If
Next RowCount
Next ColCount

'Delete columns A to D
Columns("A").Delete
'Delete Row 1
Rows(1).Delete
End Sub

 

[u473]

Thank you, you made my day.
J.P.

 

[Lionel H]

The code you posted ... was too hard to fix so I rewrote the code

I did the same thing, but not so quickly.
Thefollowing produces the result you are looking for with the data you
provided, but does it without using a third column. It also takes account of
your later info about three workbooks.

Sub Call_CompareAndShift()
Application.ScreenUpdating = False
Workbooks.Add
ActiveWorkbook.SaveAs "c:\bookc.xls"
Workbooks.Open "c:\booka.xls"
Workbooks("booka.xls").Worksheets(1).Range("A:A").Copy
Workbooks("bookc.xls").Activate
Sheets(1).Cells(1, 1).Select
Workbooks("bookc.xls").Sheets(1).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
Workbooks("booka.xls").Close
Application.DisplayAlerts = True
Workbooks.Open "c:\bookb.xls"
Workbooks("bookb.xls").Worksheets(1).Range("A:A").Copy
Workbooks("bookc.xls").Activate
Sheets(1).Cells(1, 2).Select
Workbooks("bookc.xls").Sheets(1).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
Workbooks("bookb.xls").Close
Application.DisplayAlerts = True
CompareAndShift "A:A", "B:B"
Application.ScreenUpdating = True
End Sub

Sub CompareAndShift(LRange As String, Rrange As String)
Dim aRow As Integer, bRow As Integer
Dim ShortCol As String
Dim LastRowL As Integer, LastRowR As Integer
Dim LCol As String, RCol As String

LCol = Left(LRange, 1)
RCol = Left(Rrange, 1)

Columns(LRange).Sort Key1:=Range(LCol & 1), Order1:=xlAscending
Columns(Rrange).Sort Key1:=Range(RCol & 1), Order1:=xlAscending

LastRowL = Cells(Rows.Count, LCol).End(xlUp).Row
LastRowR = Cells(Rows.Count, RCol).End(xlUp).Row

If LastRowL > LastRowR Then
bRow = LastRowL
ShortCol = RCol
Else
bRow = LastRowR
ShortCol = LCol
End If

For aRow = bRow To 1 Step -1
If Cells(aRow, LCol) = Cells(bRow, RCol) Or Cells(bRow, ShortCol) = ""
Then
'do nothing
ElseIf Cells(aRow, LCol) < Cells(bRow, RCol) Then
ShiftIt bRow, RCol, aRow, LCol
Else
ShiftIt aRow, LCol, bRow, RCol
End If
bRow = bRow - 1
Next aRow
End Sub

Sub ShiftIt(PrimaryShift As Integer, PSCol As String, SecondaryShift As
Integer, SSCol As String)
Cells(PrimaryShift, PSCol).Insert shift:=xlDown
If Cells(SecondaryShift + 1, SSCol) <> Cells(PrimaryShift + 1, PSCol) Then
Cells(SecondaryShift + 1, SSCol).Insert shift:=xlDown
Else
Cells(PrimaryShift + 2, PSCol).Delete shift:=xlUp
End If
End Sub

 

[u473]

I will study this one too. Thank you again,
J.P.