Relisting Out Data

William,

Here's an example file with your data:

http://www.asdy88.dsl.pipex.com/Experts%20Exchange/analysis_ravingnuns03.xls

The Activity Already section needs to be in a location under which there is no data as the list is very long before it is simplified. So I have placed it besides the previous table. If you want it somewhere else you can always write a simple macro to copy the results to a different location.

Now the analysis of the Activity Already is actually impossible with the data as it is. It can of course be done manually but I guess that's not viable. You cannot use COUNTIF() or SUMPRODUCT() on it as the items you need to count are in strings in the original cells.

I think that if you want the Activities Already analysed in a macro then it merits another new question.

The code for the current question is:

==Code starts below this==

Sub activity_choice()
    Dim rng1 As Range
    Dim rng2 As Range
   
    Application.ScreenUpdating = False
   
    Set rng1 = Range([a17], [iv17].End(xlToLeft))
    Set rng2 = Range([a71], [a65536].End(xlUp).Offset(0, 2))
    rng2.Clear
   
    rng1.Copy
    [a71].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Set rng2 = Range([a71], [a65536].End(xlUp))
    rng2.Sort Key1:=Range("A71"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
       
    For Each celle2 In rng2
        If celle2 = celle2.Offset(-1, 0) Then
            celle2.Offset(-1, 0).Clear
        End If
    Next celle2

    rng2.Sort Key1:=Range("A71"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    rng2.Font.Bold = True
    Set rng2 = Range([a70], [a65536].End(xlUp).Offset(0, 2))

    rng2.Borders(xlDiagonalDown).LineStyle = xlNone
    rng2.Borders(xlDiagonalUp).LineStyle = xlNone
    With rng2.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Set rng2 = Range([b71], [a65536].End(xlUp).Offset(0, 1))
    rng2.Select
   
    Application.ScreenUpdating = True
       
    [a71].Select
End Sub

Sub activities_already()
    Dim rng1 As Range
    Dim rng2 As Range
    Dim celle As Range
    Dim celle2 As Range
    Dim x As Integer
    Dim i As Integer
    Dim str() As String
   
    Application.ScreenUpdating = False
   
    Set rng1 = Range([A8], [IV8].End(xlToLeft))
    Set rng2 = Range([e71], [e65536].End(xlUp).Offset(0, 2))
    rng2.Clear
    i = 0
   
    For Each celle In rng1
        str() = Split(celle, ", ")
        For x = 0 To UBound(str)
        Cells(x + 71 + i, 5) = str(x)
        Next
        i = i + UBound(str) + 1
    Next celle
   
    Set rng2 = Range([e71], [e65536].End(xlUp))
    rng2.Sort Key1:=Range("E71"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
   
    For Each celle2 In rng2
        If celle2 = celle2.Offset(-1, 0) Then
            celle2.Offset(-1, 0).Clear
        End If
    Next celle2
   
    Set rng2 = Range([e71], [e65536].End(xlUp))
    rng2.Sort Key1:=Range("E71"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    rng2.Font.Bold = True
   
    Set rng2 = Range([e70], [e65536].End(xlUp).Offset(0, 2))
   
    rng2.Borders(xlDiagonalDown).LineStyle = xlNone
    rng2.Borders(xlDiagonalUp).LineStyle = xlNone
    With rng2.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rng2.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
   
    Application.ScreenUpdating = True
   
    [e71].Select
   
End Sub

==Code ends above this==


Patrick