Search multiple values & return single value - seperate worksheets

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I have a worksheet that has multiple laobr categories listed on different
columns and rows in a worksheet. I want to pull each value only once and
list them in different rows in a different worksheet. See example below. I
have not been able to find a way to do this - please help!
Thanks,
Jana

WORKSHEET A
A B C D E F
1 Name S1 Name S2 Name S4
2 Name S2 Name S1 Name T3
3 Name S5 Name S3 Name S1
4 Name S6 Name S4 Name E2
5 Name S7 Name E2 Name S7
6 Name S8 Name T1 Name S5

I want to deliver the data from Worksheet A, columns B, D & F into column H
in Worksheet B, but only list each value once. I do not need the data in any
certain order, just need each to only list once & have each on a different
line.

WORKSHEET B
Col H
1 S1
2 S2
3 S5
4 S6
5 S7
6 S8
7 S3
8 S4
9 E2
10 T1
11 T3
 
JANA said:
I have a worksheet that has multiple laobr categories listed on different
columns and rows in a worksheet. I want to pull each value only once and
list them in different rows in a different worksheet. See example below.
I
have not been able to find a way to do this - please help!
Thanks,
Jana

WORKSHEET A
A B C D E F
1 Name S1 Name S2 Name S4
2 Name S2 Name S1 Name T3
3 Name S5 Name S3 Name S1
4 Name S6 Name S4 Name E2
5 Name S7 Name E2 Name S7
6 Name S8 Name T1 Name S5

I want to deliver the data from Worksheet A, columns B, D & F into column
H
in Worksheet B, but only list each value once. I do not need the data in
any
certain order, just need each to only list once & have each on a different
line.

WORKSHEET B
Col H
1 S1
2 S2
3 S5
4 S6
5 S7
6 S8
7 S3
8 S4
9 E2
10 T1
11 T3
Click to expand...

I'll try to build up a formula, in the mean time the following
does the job (you must set up the 4 definitions):

============================
Sub Button52_Click()
Dim TargetRange As Range, RangeArray(1 To 3) As Range
Dim CurrentRange As Range
Dim MyDic As Object, i, j As Long, k As Long

' Definitions
Set RangeArray(1) = [Sheet10!AA11]
Set RangeArray(2) = [Sheet10!AB11]
Set RangeArray(3) = [Sheet10!AC11]
Set TargetRange = [Sheet2!A281]

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set MyDic = CreateObject("Scripting.Dictionary")
For j = 1 To 3
Set CurrentRange = RangeArray(j)
For Each i In Range(CurrentRange, CurrentRange.End(xlDown))
On Error GoTo Continue_1
MyDic.Add i.Value, i
On Error GoTo 0
k = k + 1
TargetRange.Offset(k - 1, 0) = i
Continue_2:
Next
Next

Exit_Sub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

Continue_1:
Resume Continue_2

End Sub
===========================

Ciao
Bruno
 
Might be easiest to copy all the value in B, D and F to Sheet 2 A1...end.
Then eliminate the duplicates thus:
Select the range(A1...end), use Data/Filter/Advanced filter
check Unique Records Only and "Copy to another location"
Put in an address to hold the result, [H1], then click OK. When
you're done, you will have the unique records in the new
place. You can delete the original range or not.

HTH
 
To copy data to sheet B, H2, you can use this formula

=INDEX(array_h,MOD((ROW()-2),ROWS(array_h))+1,
FLOOR((ROW()-2)/ROWS(array_h)+1,1)*2)

(array_h is the named array A1:F6)
Advanced filter needs a label. Put it into H1.
Then continue with GerryK's instructions.
 
I'll try to build up a formula, in the mean time the following
does the job (you must set up the 4 definitions):
Click to expand...
[...]

Simplifying:

==========================
Sub ColumnGroup()
Dim TargetRange As Range, SourceRangeArray(1 To 3) As Range
Dim MyDic As Object, i, j As Long

' Definitions
Set SourceRangeArray(1) = [Sheet10!AA11]
Set SourceRangeArray(2) = [Sheet10!AB11]
Set SourceRangeArray(3) = [Sheet10!AC11]
Set TargetRange = [Sheet2!A281]

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set MyDic = CreateObject("Scripting.Dictionary")
For j = 1 To 3
For Each i In Range(SourceRangeArray(j),
SourceRangeArray(j).End(xlDown))
On Error Resume Next
MyDic.Add i.Value, i
On Error GoTo 0
Next
Next

Range(TargetRange, TargetRange.Offset(MyDic.Count - 1, 0)) = _
Application.Transpose(MyDic.Keys)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
===========================

Ciao
Bruno
 
Back
Top