Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees.
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. |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees.
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 "u473" wrote: 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. |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees.
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:D").Delete 'Delete Row 1 Rows(1).Delete End Sub "u473" wrote: 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. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees.
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. |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees
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:D").Delete 'Delete Row 1 Rows(1).Delete End Sub "u473" wrote: 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. |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees
Thank you, you made my day.
J.P. |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees
"Joel" wrote: 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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Compare & align like items from 2 Roaster columns of Employees
I will study this one too. Thank you again,
J.P. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Compare 2 columns and align duplicates into same row | Excel Worksheet Functions | |||
Compare and align columns of data | Excel Programming | |||
What formula can I use to compare items in two columns | Excel Programming | |||
Macro to align & compare multiple columns with several rows | Excel Programming | |||
Macro to align and compare multiple rows and columns | New Users to Excel |