Compare Names in a column and create single list with adjacent vla

G

George

Good Morning,

Here's the challenge the information shown below is on a single worksheet.
What I need to do is create a single column of names from Columns A,C,E,G.
The adjacent columns B, D, F, H contains values associated with each name and
need to be added next to the proper name in the new list...Below I added what
is looks like currently and how it need to look after run the macro or VB
script.

Col A Data1 Col C Data 2 Col E Data 3 Col G
Data 4
Name1 0.3 Name1 100% Name 1 15 Name1 0.1
Name2 0.5 Name2 10% Name 2 12 Name2 0.2
Name3 0.7 Name3 90% Name 4 18 Name4 0.3
Name4 0.7 Name4 90% Name 5 18 Name5 0.3

Below is how the result should look

Col A Data1 Data 2 Data 3 Data 4
Name1 0.3 100% 15 0.1
Name2 0.5 10% 12 0.2
Name3 0.7 90%
Name4 0.7 90% 18 0.3
Name5 18 0.3

Thank You in Advance for any assistance..
Respectfully,
George
 
J

joel

This is very similar to a request I did on Sunday. I modified the cod
from Sunday below. Here is the link to Sundays request
http://tinyurl.com/33sz3mj


Sub LookupNames()

'put names into column IV
'then use advancefilter to put names at bottom
'of worksheet

'use data in column A to get Last Row
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'put final list 5 rows down from last date
NewRow = LastRow + 5

'put header in IV1 so advance filter doesn't create duplicate entry
Range("IV1") = "Unique Names"
'copy first set of names in column B to column IV
Range("A1:A" & LastRow).Copy _
Destination:=Range("IV2")
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
'Copy Second List of names in column D to column IV
Range("C1:C" & LastRow).Copy _
Destination:=Range("IV" & (LastRowNewData + 1))
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
'Copy third List of names in column F to column IV
Range("E1:E" & LastRow).Copy _
Destination:=Range("IV" & (LastRowNewData + 1))
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
Range("G1:G" & LastRow).Copy _
Destination:=Range("IV" & (LastRowNewData + 1))
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
'use Advance filter to move copy data
'put Data 1 starting one row below NewRow
Range("IV1:IV" & LastRowNewData).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("A" & (NewRow - 1)), _
Unique:=True

'delete temporary data in column IV
Columns("IV").Delete

LastRowUnique = Range("A" & Rows.Count).End(xlUp).Row
'Unique names goes from NewRow to LastRowUnique
'=IF(ISERROR(VLOOKUP(A10,A$1:A$4,2,False)),"",VLOOKUP(A10,A$1:A$4,2,False))
'=IF(ISERROR(VLOOKUP(A10,C$1:C$4,2,False)),"",VLOOKUP(A10,C$1:C$4,2,False))
'=IF(ISERROR(VLOOKUP(A10,E$1:E$4,2,False)),"",VLOOKUP(A10,E$1:E$4,2,False))
'=IF(ISERROR(VLOOKUP(A10,G$1:G$4,2,False)),"",VLOOKUP(A10,G$1:G$4,2,False))

Lookup1Str = "VLookup(A" & NewRow & ",A$1:B$" & LastRow & ",2,False)"
Lookup2Str = "VLookup(A" & NewRow & ",C$1:D$" & LastRow & ",2,False)"
Lookup3Str = "VLookup(A" & NewRow & ",E$1:F$" & LastRow & ",2,False)"
Lookup4Str = "VLookup(A" & NewRow & ",G$1:H$" & LastRow & ",2,False)"

Range("B" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup1Str & "),""""," & Lookup1Str & ")"
Range("C" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup2Str & "),""""," & Lookup2Str & ")"
Range("D" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup3Str & "),""""," & Lookup3Str & ")"
Range("E" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup4Str & "),""""," & Lookup4Str & ")"


'copy formula down column B for each unique name
Range("B" & NewRow & ":E" & NewRow).Copy _
Destination:=Range("B" & NewRow & ":B" & LastRowUnique)

End Sub
 
G

George

Hi Joel,

Thanks for your post and reference link. I ran the routine and it does place
the names in column "A" with its adjacent values, however what I'm realyy
needing to do is have the name listed once In Column "A" and any value having
the same name association place it in the appropriate columns B, C, D & E
next to the name.

So if you have any additional suggestion that would be great.

thanks again.
George
 
J

joel

Try adjusting the column widths. The code places formulas in columns B
C, D, & E. Do you have the formulas? Are you looking to put value
instead of formulas? Not sure why you aren't getting the correc
results. The code works properly on my PC.

The code puts the results in Columns A four rows below the end of you
data. Check to make sure there isn't anything else in column A belo
your data.
 
G

George

Hi Joel,

I really wanted just the values but the formula's are ok. I've attached the
results I'm getting which are close but not quite there yet. I don't want the
headers "Col C", "Col E", & "Col G" in the list of names in Col A.
Additionally, I want the headers "Data 2', "Data 3" & "Data 4" at the top of
their respective columns. Finally, the data that was used to create the list
can be deleted.

Unique Names
Col A Data 1
Name1 0.3 1 15 0.1
Name2 0.5 0.1 12 0.2
Name3 0.7 0.9
Name4 0.7 0.9 18 0.3
Col c Data2
Col E Data3
Name5 18 0.3
Col G Data 4


Many Thanks Again,
George
 
J

joel

The changes you asked for were pretty simple to make. i didn't test the
changes but I'm pretty confident they should work. I used Pastespecial
to remove the formulas and then deleted the rows with the original data.
I had to replace the values otherwise when I delete the orginal data
the formulas data would be lost.

Using formulas like this makes the macro run quicker than other methods.
It looks like a lot of code, but if you look closely I just repeating
the same basic method over and over again. It only takes me about 10
minutes to write this macro. It probably would take you hours.

I wasn't sure when I wrote the macro if you had a header row or didn't
have a header row. To remove the headers I changed some of the copy
methods to start at row 2 instead of row 1.


Sub LookupNames()

'put names into column IV
'then use advancefilter to put names at bottom
'of worksheet

'use data in column A to get Last Row
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'put final list 5 rows down from last date
NewRow = LastRow + 5

'put header in IV1 so advance filter doesn't create duplicate entry
Range("IV1") = "Unique Names"
'copy first set of names in column B to column IV
Range("A2:A" & LastRow).Copy _
Destination:=Range("IV2")
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
'Copy Second List of names in column D to column IV
Range("C2:C" & LastRow).Copy _
Destination:=Range("IV" & (LastRowNewData + 1))
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
'Copy third List of names in column F to column IV
Range("E2:E" & LastRow).Copy _
Destination:=Range("IV" & (LastRowNewData + 1))
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
Range("G2:G" & LastRow).Copy _
Destination:=Range("IV" & (LastRowNewData + 1))
'get last row of new data
LastRowNewData = Range("IV" & Rows.Count).End(xlUp).Row
'use Advance filter to move copy data
'put Data 1 starting one row below NewRow
Range("IV1:IV" & LastRowNewData).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("A" & (NewRow - 1)), _
Unique:=True

'Put Headers above row
Range("B" & (NewRow - 1)) = "Data 1"
Range("C" & (NewRow - 1)) = "Data 2"
Range("D" & (NewRow - 1)) = "Data 3"
Range("E" & (NewRow - 1)) = "Data 4"

'delete temporary data in column IV
Columns("IV").Delete

LastRowUnique = Range("A" & Rows.Count).End(xlUp).Row
'Unique names goes from NewRow to LastRowUnique
'=IF(ISERROR(VLOOKUP(A10,A$2:A$4,2,False)),"",VLOOKUP(A10,A$2:A$4,2,False))
'=IF(ISERROR(VLOOKUP(A10,C$2:C$4,2,False)),"",VLOOKUP(A10,C$2:C$4,2,False))
'=IF(ISERROR(VLOOKUP(A10,E$2:E$4,2,False)),"",VLOOKUP(A10,E$2:E$4,2,False))
'=IF(ISERROR(VLOOKUP(A10,G$2:G$4,2,False)),"",VLOOKUP(A10,G$2:G$4,2,False))

Lookup1Str = "VLookup(A" & NewRow & ",A$2:B$" & LastRow & ",2,False)"
Lookup2Str = "VLookup(A" & NewRow & ",C$2:D$" & LastRow & ",2,False)"
Lookup3Str = "VLookup(A" & NewRow & ",E$2:F$" & LastRow & ",2,False)"
Lookup4Str = "VLookup(A" & NewRow & ",G$2:H$" & LastRow & ",2,False)"

Range("B" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup1Str & "),""""," & Lookup1Str & ")"
Range("C" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup2Str & "),""""," & Lookup2Str & ")"
Range("D" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup3Str & "),""""," & Lookup3Str & ")"
Range("E" & NewRow).Formula = _
"=IF(ISERROR(" & Lookup4Str & "),""""," & Lookup4Str & ")"

'copy formula down column B for each unique name
Range("B" & NewRow & ":E" & NewRow).Copy _
Destination:=Range("B" & NewRow & ":B" & LastRowUnique)

'replace formulas with values
Rows(NewRow & ":" & LastRowUnique).Copy
Rows(NewRow & ":" & LastRowUnique).PasteSpecial _
Paste:=xlPasteValues

'delete orignal data
Rows("1:" & (NewRow - 2)).Delete
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Find a number in a column then return a value from another cell 2
VBA for summing buys and sells 0
calculating probabilty of x number of successes with multiple tria 15
Data from two sheets make up a list in a third sheet (real time) 1
RANK Function - Zero Value Ranked as 1 - Should be 10 8
Multiple Controls in a Dynamic UserForm 1
A Challenge! Can you handle it??? 4
Returning other cells with the same value in a column, but different row. 1

Top