Combing list and V-lookup

[varcorb]

Hello,

I am trying to get a list on a separate tab of two columns. I have the following:

	Column B	Column S
1	1/4	1@2
2	3/8	2@4
3	1/4 <colgroup><col></colgroup><tbody> </tbody>	2@4

<tbody>
</tbody>

And am trying to get add:

	Column 1	Column 2
1	1/4	1@2 AND 2@4
2	3/8	2@4

<tbody>
</tbody>

<tbody>
</tbody>

Any Idea How i can do that? I have tried v-lookup and that doesn't work.


Thank You

 

[hiker95]

varcorb,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


How about a macro solution?

Sample raw data in worksheet Sheet1:

Excel 2007
	B	S
1	1/4	1@2
2	3/8	2@4
3	1/4	2@4
4
Sheet1

After the macro in a new worksheet Results:

Excel 2007
	A	B
1	1/4	1@2 AND 2@4
2	3/8	2@4
3
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub Combine_B_S()
' hiker95, 06/10/2014, ME783472
Dim w1 As Worksheet, wr As Worksheet
Dim c As Range, rng As Range
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Worksheets("Results")
wr.Columns("A:B").Clear
Set rng = w1.Range(w1.Range("B1"), w1.Range("B" & Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In rng
    If c <> "" Then
      If Not .Exists(c.Value) Then
        .Add c.Value, c.Offset(, 17)
      Else
        .Item(c.Value) = .Item(c.Value) & " AND " & c.Offset(, 17)
      End If
    End If
  Next
  wr.Cells(1).Resize(.Count).NumberFormat = "@"
  wr.Cells(1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
End With
With wr
  .Columns("A:B").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the Combine_B_S macro.

 

[varcorb]

Thank You hiker95! That looks good. I am running Excel 2011 on Mac. I was given an error For ActiveX not being activated. I don't believe ActiveX will run on my mac.

 

[hiker95]

varcorb,

Thanks for the feedback. You are very welcome.

Sorry that I can not help you any further. I do not have any experience with a Mac.

In the future when you ask for help, so that you can get the right type of help from the get go, you should put in the title "on a Mac", and, maybe even the version of Windows and Excel that you are using.

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.

 

[hiker95]

varcorb,

I would like you to try the below macro with a function. It does not utilize the Scripting.Dictionary, and, may not cause the error you encountered.

With the same screenshots as my reply #2.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub Combine_B_S_V2()
' hiker95, 06/10/2014, ME783472
Dim w1 As Worksheet, wr As Worksheet
Dim a As Variant, o As Variant, x
Dim i As Long, j As Long, k As Long, n As Long
Dim lr As Long, nlr As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Worksheets("Results")
wr.Columns("A:B").Clear
With w1
  lr = .Cells(Rows.Count, "B").End(xlUp).Row
  a = .Range("B1:S" & lr)
  nlr = CountUnique(.Range("B1:B" & lr))
End With
ReDim o(1 To nlr, 1 To 2)
ReDim x(1 To nlr)
For i = 1 To UBound(a, 1)
  On Error Resume Next
  n = WorksheetFunction.Match(a(i, 1), x, 0)
  If Err.Number <> 0 Then   '***there was no match***
    k = k + 1
    x(k) = a(i, 1)
    j = j + 1
    o(j, 1) = a(i, 1)
    o(j, 2) = a(i, 18)
  Else                      '***there is a match***
    o(n, 2) = o(n, 2) & " AND " & a(i, 18)
  End If
  On Error GoTo 0
Next i
With wr
  .Cells(1).Resize(nlr).NumberFormat = "@"
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns("A:B").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub
Function CountUnique(ByVal Rng As Range) As Long
'' Juan Pablo González, MrExcel MVP, 05/09/2003
'' http://www.mrexcel.com/forum/excel-questions/48385-need-count-unique-items-column-visual-basic-applications.html
Dim St As String
Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
St = "'" & Rng.Parent.Name & "'!" & Rng.Address(False, False)
CountUnique = Evaluate("SUM(IF(LEN(" & St & "),1/COUNTIF(" & St & "," & St & ")))")
End Function

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the Combine_B_S_V2 macro.

 

[varcorb]

This works perfect. Thank You so much! It has been a huge help to me! I appreciate it very much!

 

[hiker95]

varcorb,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.