help needed -- link data in 1 cell

[rainx]

Sample data:
<table x:str="" style="border-collapse: collapse; width: 189pt;" width="252" border="0" cellpadding="0" cellspacing="0"><col style="width: 90pt;" width="120"> <col style="width: 99pt;" width="132"> <tbody><tr style="height: 15pt;" height="20"> <td class="xl62" style="height: 15pt; width: 90pt;" width="120" height="20">Machine</td> <td class="xl63" style="width: 99pt;" width="132">Part Number</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 1</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">123</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 2</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">123</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 3</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">123</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 1</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">123</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 2</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">456</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 1</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">456</td> </tr> <tr style="height: 14.25pt;" height="19"> <td class="xl64" style="height: 14.25pt; width: 90pt;" width="120" height="19">machine 3</td> <td class="xl65" style="width: 99pt;" x:num="" width="132" align="right">456</td> </tr> </tbody></table>
Hi everyone, I have this problem here, that i need to based on tis sample data come out with sth like tt:

<table x:str="" style="border-collapse: collapse; width: 326pt;" width="434" border="0" cellpadding="0" cellspacing="0"><col style="width: 90pt;" width="120"> <col style="width: 236pt;" width="314"> <tbody><tr style="height: 12.75pt;" height="17"> <td class="xl62" style="height: 12.75pt; width: 90pt;" width="120" height="17">
</td> <td class="xl62" style="width: 236pt;" width="314">Used In:</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl62" style="height: 12.75pt;" x:num="" height="17">123</td> <td class="xl62">Machine 1, Machine 2, Machine 3</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl62" style="height: 12.75pt;" x:num="" height="17">456</td> <td class="xl62">Machine 2, Machine 1, Machine 3</td> </tr> </tbody></table>

I need to group those machines under 1 part number. For instance, part 123 is used in which machines, I need to state them in a way like above. But repeated should not be stated again.

Hope someone is able to help.

Thanks alot in advance!

 

[DonkeyOte]

Rainx, are you returning all machine strings into one cell or trying to transpose the data such that machine 1 goes in column 2, machine 2 in column 3 etc...

 

[jindon]

try

Sub test()
Dim a, b(), i As Long, n As Long, temp As String, e
a = Range("a1").CurrentRegion.Resize(,2).Value
ReDim b(1 To UBound(a,1), 1 To 2)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 2 To UBound(a,1)
        If Not .exists(a(i,2)) Then
            n = n + 1 : b(i,1) = a(i,2) : .add a(i,2), n
        End If
        b(.item(a(i,2)), 2) = b(.item(a(i,2)), 2) & _
                IIf(b(.item(a(i,2)), 2) <> "", ",", "") & a(i,1)
    Next
    .removeall
    For i = 1 To n
        For Each e In Split(b(i,2),",")
            If Not .exists(e) Then
                temp = temp & "," & e
                .add e, Nothing
            End If
            b(i,2) = Mid$(temp,2)
            temp = "" : .removeall
        Next
    Next
End With
Range("d1").Resize(n,2).Value = b
End Sub

 

[rainx]

To Lasw10:

Yup, return into 1 cell, not transpose...

To Jindon:

I will try out. Thanks alot!

 

[rainx]

The code is not working, it only grp the first part number, but the machines names were in 2 cells instead of all in 1, the machine reflected were wrong too.. sth like that:

<table x:str="" style="border-collapse: collapse; width: 130pt;" width="173" border="0" cellpadding="0" cellspacing="0"><col style="width: 48pt;" width="64"> <col style="width: 82pt;" width="109"> <tbody><tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt; width: 48pt;" width="64" height="17">
</td> <td class="xl24" style="width: 82pt;" width="109">Machine 3</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">123</td> <td class="xl24">Machine 1</td> </tr> </tbody></table>
Something like that...

Thanks!

 

[DonkeyOte]

Rainx, I will let Jindon resolve this, I won't pretend to understand it

 

[DonkeyOte]

Rainx, I will let Jindon resolve this, I won't pretend to understand it ray:

 

[cornflakegirl]

That's some serious adulation there, Luke. Not that Jindon doesn't deserve it

 

[Norie]

Try this.

Option Explicit
Sub GetMachines()
Dim wsData As Worksheet
Dim wsUnique As Worksheet
Dim LastRow As Long
Dim rng As Range
Dim arrVals As Variant
Dim F As Long
Dim S As Long
Dim I As Long
    Set wsData = Worksheets("Data")
    Set wsUnique = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    wsData.Range("A1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsUnique.Range("A1:B1"), Unique:=True
    
    Set rng = wsUnique.Range("B2")
    
    S = 2
    
    While rng.Value <> ""
    
        If rng.Value <> rng.Offset(1) Then
        
            I = I + 1
            
            F = rng.Row - 1
            
           arrVals = wsUnique.Range("B" & S).Resize(F - S + 2).Offset(, -1)
           
           arrVals = Application.Transpose(arrVals)
            
           wsData.Range("E" & I) = rng.Value
           
            wsData.Range("F" & I) = Join(arrVals, ",")
            
            S = S + F
            
        End If
        
        Set rng = rng.Offset(1)
        
    Wend
    
    Application.DisplayAlerts = False
    wsUnique.Delete
    Application.DisplayAlerts = True
End Sub

 

[facethegod]

Try

Option Explicit
Sub tst()
Dim aCol As New Collection, b(), c() As String, i As Integer, x As Integer
Dim a
With Application
a = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To UBound(a, 1))
For i = 1 To UBound(a, 1)
On Error Resume Next: aCol.Add Item:=a(i, 2), Key:=CStr(a(i, 2)): b(i) = a(i, 2)
Next
On Error GoTo 0: ReDim c(1 To aCol.Count, 1 To 2)

For i = 1 To aCol.Count
c(i, 1) = aCol.Item(i)
Do Until IsError(.Match(aCol.Item(i), b, 0))
x = .Match(aCol.Item(i), b, 0)
c(i, 2) = IIf(c(i, 2) = "", a(x, 1), c(i, 2) & "," & a(x, 1)): b(x) = Empty
Loop
Next
Range("D2").Resize(UBound(c, 1), 2).Value = c
End With
End Sub