|
Match consolidate multiple rows data into one row
Hi Francis,
Try, change according to your needs this suppose that duplicates are in column B starting to check in row 6 'delete duplicates Dim TestColumn As String Dim RowNdx As Long Dim TopRow As Long Dim LastRow As Long Dim WS As Worksheet Dim DeleteThese As Range Worksheets("Summary").Select Set WS = ActiveSheet TestColumn = "B" '<<<< column to test for duplicates TopRow = 6 '<<<< top-most row of data to test. With WS LastRow = .Cells(.Rows.Count, TestColumn).End(xlUp).Row For RowNdx = LastRow To TopRow Step -1 If Application.CountIf(.Range(.Cells(TopRow, TestColumn), _ .Cells(RowNdx, TestColumn)), _ .Cells(RowNdx, TestColumn)) 1 Then If DeleteThese Is Nothing Then Set DeleteThese = .Rows(RowNdx) Else Set DeleteThese = _ Application.Union(DeleteThese, .Rows(RowNdx)) End If End If Next RowNdx End With If Not DeleteThese Is Nothing Then DeleteThese.Delete End If Sheets("Summary").Select 'This macro delete all rows with a blank cell in column B On Error Resume Next 'In case there are no blank cells Columns("B").SpecialCells(xlCellTypeBlanks).Entire Row.Delete On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(what:="*", _ after:=sh.Range("B1"), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function "francis" wrote: Hi How do I achieve this in formula, Customer Address E_mail ABC Cone 700 W.ST 2RD ABC Cone 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN LUXURY SUITES 6616 DAVIS BLVD MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 555 SOUTH PENGUIN Expected Result Customer Address E_mail ABC Concrete 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 555 SOUTH PENGUIN TIA -- Thank You cheers, francis |
Match consolidate multiple rows data into one row
Hi Eduardo
Thanks for the effort but the macro does nothing as the Summary page is blank as a result after running the code. Is there formulas that can do this? -- Hope this is helpful Pls click the Yes button below if this post provide answer you have asked Thank You cheers, francis "Eduardo" wrote: Hi Francis, Try, change according to your needs this suppose that duplicates are in column B starting to check in row 6 'delete duplicates Dim TestColumn As String Dim RowNdx As Long Dim TopRow As Long Dim LastRow As Long Dim WS As Worksheet Dim DeleteThese As Range Worksheets("Summary").Select Set WS = ActiveSheet TestColumn = "B" '<<<< column to test for duplicates TopRow = 6 '<<<< top-most row of data to test. With WS LastRow = .Cells(.Rows.Count, TestColumn).End(xlUp).Row For RowNdx = LastRow To TopRow Step -1 If Application.CountIf(.Range(.Cells(TopRow, TestColumn), _ .Cells(RowNdx, TestColumn)), _ .Cells(RowNdx, TestColumn)) 1 Then If DeleteThese Is Nothing Then Set DeleteThese = .Rows(RowNdx) Else Set DeleteThese = _ Application.Union(DeleteThese, .Rows(RowNdx)) End If End If Next RowNdx End With If Not DeleteThese Is Nothing Then DeleteThese.Delete End If Sheets("Summary").Select 'This macro delete all rows with a blank cell in column B On Error Resume Next 'In case there are no blank cells Columns("B").SpecialCells(xlCellTypeBlanks).Entire Row.Delete On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(what:="*", _ after:=sh.Range("B1"), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function "francis" wrote: Hi How do I achieve this in formula, Customer Address E_mail ABC Cone 700 W.ST 2RD ABC Cone 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN LUXURY SUITES 6616 DAVIS BLVD MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 555 SOUTH PENGUIN Expected Result Customer Address E_mail ABC Concrete 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 555 SOUTH PENGUIN TIA -- Thank You cheers, francis |
Match consolidate multiple rows data into one row
Hi Francis,
The summary page was my example, you have to replace that name for your tab name What the macro will do is to look into your tab and delete any duplication, is that what you want to do or you want to copy your information in another tab and then delete the duplicates "francis" wrote: Hi Eduardo Thanks for the effort but the macro does nothing as the Summary page is blank as a result after running the code. Is there formulas that can do this? -- Hope this is helpful Pls click the Yes button below if this post provide answer you have asked Thank You cheers, francis "Eduardo" wrote: Hi Francis, Try, change according to your needs this suppose that duplicates are in column B starting to check in row 6 'delete duplicates Dim TestColumn As String Dim RowNdx As Long Dim TopRow As Long Dim LastRow As Long Dim WS As Worksheet Dim DeleteThese As Range Worksheets("Summary").Select Set WS = ActiveSheet TestColumn = "B" '<<<< column to test for duplicates TopRow = 6 '<<<< top-most row of data to test. With WS LastRow = .Cells(.Rows.Count, TestColumn).End(xlUp).Row For RowNdx = LastRow To TopRow Step -1 If Application.CountIf(.Range(.Cells(TopRow, TestColumn), _ .Cells(RowNdx, TestColumn)), _ .Cells(RowNdx, TestColumn)) 1 Then If DeleteThese Is Nothing Then Set DeleteThese = .Rows(RowNdx) Else Set DeleteThese = _ Application.Union(DeleteThese, .Rows(RowNdx)) End If End If Next RowNdx End With If Not DeleteThese Is Nothing Then DeleteThese.Delete End If Sheets("Summary").Select 'This macro delete all rows with a blank cell in column B On Error Resume Next 'In case there are no blank cells Columns("B").SpecialCells(xlCellTypeBlanks).Entire Row.Delete On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(what:="*", _ after:=sh.Range("B1"), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function "francis" wrote: Hi How do I achieve this in formula, Customer Address E_mail ABC Cone 700 W.ST 2RD ABC Cone 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN LUXURY SUITES 6616 DAVIS BLVD MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 555 SOUTH PENGUIN Expected Result Customer Address E_mail ABC Concrete 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 555 SOUTH PENGUIN TIA -- Thank You cheers, francis |
Match consolidate multiple rows data into one row
Hi Eduardo
Thanks for the reply. What I like to do is 1) to check column A with column B whether they are the same 2) if they are the same, then check column C if the Emails are the same 3) if the range in column A, B, and C are the same, I need only return the same email, otherwise return all the email which are different 4) Col A may have the same name but the Address in col B may be different, then I need to return col A, B and the email relating to Col B Hope I have explained myself well. I apology for not able to explain well enough -- Thank You cheers, francis "Eduardo" wrote: Hi Francis, The summary page was my example, you have to replace that name for your tab name What the macro will do is to look into your tab and delete any duplication, is that what you want to do or you want to copy your information in another tab and then delete the duplicates "francis" wrote: Hi Eduardo Thanks for the effort but the macro does nothing as the Summary page is blank as a result after running the code. Is there formulas that can do this? -- Hope this is helpful Pls click the Yes button below if this post provide answer you have asked Thank You cheers, francis "Eduardo" wrote: Hi Francis, Try, change according to your needs this suppose that duplicates are in column B starting to check in row 6 'delete duplicates Dim TestColumn As String Dim RowNdx As Long Dim TopRow As Long Dim LastRow As Long Dim WS As Worksheet Dim DeleteThese As Range Worksheets("Summary").Select Set WS = ActiveSheet TestColumn = "B" '<<<< column to test for duplicates TopRow = 6 '<<<< top-most row of data to test. With WS LastRow = .Cells(.Rows.Count, TestColumn).End(xlUp).Row For RowNdx = LastRow To TopRow Step -1 If Application.CountIf(.Range(.Cells(TopRow, TestColumn), _ .Cells(RowNdx, TestColumn)), _ .Cells(RowNdx, TestColumn)) 1 Then If DeleteThese Is Nothing Then Set DeleteThese = .Rows(RowNdx) Else Set DeleteThese = _ Application.Union(DeleteThese, .Rows(RowNdx)) End If End If Next RowNdx End With If Not DeleteThese Is Nothing Then DeleteThese.Delete End If Sheets("Summary").Select 'This macro delete all rows with a blank cell in column B On Error Resume Next 'In case there are no blank cells Columns("B").SpecialCells(xlCellTypeBlanks).Entire Row.Delete On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(what:="*", _ after:=sh.Range("B1"), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function "francis" wrote: Hi How do I achieve this in formula, Customer Address E_mail ABC Cone 700 W.ST 2RD ABC Cone 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN LUXURY SUITES 6616 DAVIS BLVD MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 555 SOUTH PENGUIN Expected Result Customer Address E_mail ABC Concrete 700 W.ST 2RD ACME 701 ACME DR SANDALWOOD 200 SANDALWOOD AVE DIGITAL TIMES 919 N MAIN ST LUXURY SUITES 6616 DAVIS BLVD LUXURY SUITES 808 E MAIN MISHMASH 350 MISHMASH PARKWAY XYZ FOUNDATIONS 502 WEST LITTLE XYZ FOUNDATIONS 123 MAIN XYZ FOUNDATIONS 555 SOUTH PENGUIN TIA -- Thank You cheers, francis |
| All times are GMT +1. The time now is 11:47 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com