Group data from a row into different columns

[KyleG]

In this mockup of a sheet i need a macro that will on another sheet in columns list the people with the same status

Book1
	A	B	C	D	E	F	G	H	I	J
1	fred	george	Harry	Ron	Dean	Neville	bob	john	sarah	lucy
2	high	low	average	perfect	average	average	low	low	high	not worked
Sheet1

Book1
	A	B	C	D	E
1	Not Worked	Low	Average	Perfect	HIGH
2	Lucy	George	Harry	Ron	Fred
3		Bob	Dean		Sarah
4		john	Neville
Sheet2

Thanks

 

[venkat1926]

see sheet below
rows 13 and down are AFTER MACRO
DELETE rows 13,14,15. KEEP row 12 as it is (they are unique values of status)

now again run the macro test given below modify macro to suit you)

(if necessary cut and copy rows 12 downwards into another sheet- you can incorporate this into the macro)

Sub test()
Dim add As String
Dim dest As Range
Dim cfind As Range
Dim crit As Range
Dim i As Integer
Dim j As Integer
Dim rng As Range
Set rng = Range(Range("a1"), Cells(4, Columns.Count).End(xlToLeft))
Set crit = Range("a12")
line1:
With rng
Set cfind = .Find(what:=crit.Value, lookat:=xlWhole)
add = cfind.Address
crit.Offset(1, 0) = cfind.Offset(-2, 0)
j = 1
i = 1
Do

On Error Resume Next
Set cfind = .FindNext(after:=cfind)
If cfind.Address = add Then
Set crit = crit.Offset(0, i)
If crit = "" Then GoTo line2
GoTo line1
End If
crit.Offset(j + 1, 0) = cfind.Offset(-2, 0)

j = j + 1

Loop While cfind.Address<> add
line2:

End With
MsgBox "macro over"

End Sub

vlookup mltiple values.xls
	A	B	C	D	E	F	G	H	I	J
1
2	fred	george	Harry	Ron	Dean	Neville	bob	john	sarah	lucy
3
4	high	low	average	perfect	average	average	low	low	high	not worked
5
6
7
8
9
10
11
12	high	low	average	not worked
13	fred	george	Harry	lucy
14	sarah	bob	Dean
15		john	Neville
Sheet1

 

[KyleG]

I'm struggling to convert this so that it puts it automatically onto sheet2 with the headers on row A.

The other point to note is that on sheet 1 the names start in A2 and go across, and the values (high, low etc) are below them on Row 8. If you could make comments on each line of your code i might be able to translate.

Thanks

 

[venkat1926]

I have modified the macro to get the results in sheet2
pre-enter the values low high etc (as in row 12 of the sheet 1) in row no. 1 of sheet2 fro A1 to the right.

now run this modified macro now called "testone". i have checked the existing row 2 and row 4 data . I have incorporated so that your data conists upto eight rows the data in alternate rows I have given comments . I could not check eight rows data because I do not have them.


still there may some bug and the macro may require slight modification to suit you which can be done by debugging-keep cursor within the macro testone and sucessively hit F8. find out where the bug comes and you can rectify.

If you cannot correct it post 8 rows data or send it to my email address as an excel file

if successful you can delete the comment lines. some comment lines are OLD code statements.

I SUGGEST YOU RUN THE FOLLOWING MACRO ON YOUR EIGHT ROW DATA AND SEE WHAT HAPPENS.

the new macro testone is :

Dim add As String
Dim dest As Range
Dim cfind As Range
Dim crit As Range
Dim i As Integer
Dim j As Integer
Dim rng As Range
 Worksheets("sheet1").Activate
'Set rng = Range(Range("a1"), Cells(4, Columns.Count).End(xlToLeft))
'rng is your basic data consisting row2 upto row 4 or 8 with the last column in this case J
Set rng = Range(Range("a2"), Cells(8, Columns.Count).End(xlToLeft))

Set crit = Worksheets("sheet2").Range("a1")
'the unique values like high, low etc are pre-entered in row 12
line1:
With rng
Set cfind = .Find(what:=crit.Value, lookat:=xlWhole)
'it finds the first value equivalent to the value of range "crit" in the first case A12 value i.e. "high"
add = cfind.Address
'you must know the address of the first find of for example "high"
'because the find value in the next findnext is cricular.
'after finding all the value in rng it comes back to the firt high value
'so the looping in the find next should stop when it come back the first "high"
crit.Offset(1, 0) = cfind.Offset(-2, 0)
j = 1
i = 1
Do

On Error Resume Next
Set cfind = .FindNext(after:=cfind)
'findnext finds the next value of "high"
If cfind.Address = add Then
'if cfind is the first high value the looping has to stop and then
Set crit = crit.Offset(0, i)
'crit should go to the next value in row 12 i.e. "low"

If crit = "" Then GoTo line2
'when crit goes beyond the four values of row 12 the macro should stop
GoTo line1
' this is only a sort of looping
End If
crit.Offset(j + 1, 0) = cfind.Offset(-2, 0)
'this statement enters the first value of the name of the person of that category crit
j = j + 1

Loop While cfind.Address <> add
line2:

End With

MsgBox "macro over"
End Sub

 

[KyleG]

The cells value that contain Not worked, average etc below each persons name are actually genenerated by a formula
=IF((SUM((COUNTIF(B17:B30,0))+(COUNTIF(B17:B30,"n/a"))+((COUNTIF(B17:B30,">=-2")-COUNTIF(B17:B30,">2"))-(COUNTIF(B17:B30,0)))+(COUNTIF(B17:B30,"<-2")+COUNTIF(B17:B30,">2"))))<>14,"NES",IF((COUNTIF(B17:B30,"n/a"))>10,"NES",IF((COUNTIF(B17:B30,0))+(COUNTIF(B17:B30,"n/a"))=14,"PERFECT",IF((COUNTIF(B17:B30,"<-2")+COUNTIF(B17:B30,">2"))>=4,"POOR",IF((COUNTIF(B17:B30,"<-2")+COUNTIF(B17:B30,">2"))=0,"HIGH","AVERAGE")))))
This particlar cell returns "PERFECT" but your formula doesnt recognise it. If i take out the formula and insert PERFECT text it does.

 

[venkat1926]

please see my code statement

Set cfind = .Find(what:=crit.Value, lookat:=xlWhole)

change this into

Set cfind = .Find(what:=crit.Value, lookat:=xlWhole,lookin:=xlvalues)

argument LOOKIN is the addition

now see whether you get what you want.

 

[KyleG]

Spot on! thanks heaps for all your help.