We help IT Professionals succeed at work.

Need help with a excel macro

Hi All,

Need help with a excel macro
I have a file as attached. I need help creating a report as shown in the other sheel

i will have software names in the cell with a , coma and without some times as in each line within a cell. Some coma's may have 1 or more space in between software names.

The excel would have clear data .
Can anyone help.

thanks Sample.xls
Comment
Watch Question

Are the software titles fixed (i.e., users are entering/selecting from a finite list) or free form (i.e., users can enter whatever they want)?  For example, will "IIS" always be "IIS" or might you see "IIS 6", "IIS6", "IIS6.0", "IIS7", etc.?

Author

Commented:
They are entering as they want
Once i get it as the report can find the differences manually and edit and run macro again
Do you have any control over the entry "portal"?  Can you provide the end-users with a form/shared workbook with a finite list of choices?  Creating the report will be heaps easier if you have consistent data.  After years of experience, I continue to be "amused" at the variety of ways the end-user community can describe the same thing.  You can expect n x 50% variation (where n is the number of end-users) if you are forced to accept free-form data.  My concern is that you'll have a lot of cleanup work if you have any significant number of entries to work with.
Commented:
Here is my code that creates a new report on a sheet3. I hope it helps.  It is not a  robust, since it still depends on the consistency of entries and entry styles.

Sub CreateNewReport()
Worksheets("Sheet1").Activate

Dim Product()
ReDim Product(0)

For r = 2 To 10
    
    flag = 0
    For rr = 1 To UBound(Product, 1)
        If Product(rr) = Cells(r, 6) Then
            flag = 1
            Exit For
        End If
    Next rr
    If flag = 0 Then
        ReDim Preserve Product(UBound(Product, 1) + 1)
        ndex = ndex + 1
    
        Product(ndex) = Cells(r, 6)
        
    End If
Next r

Dim SummaryProd()
ReDim SummaryProd(1, 0)



For r = 1 To UBound(Product, 1)
    ndx = ndx + 1
    Worksheets("Sheet3").Cells(ndx, 1) = Product(r)
    
    ReDim SummaryProd(1, 0)
    For rr = 2 To 10
    If Worksheets("Sheet1").Cells(rr, 6) = Product(r) Then
        a = getSubText(Worksheets("Sheet1").Cells(rr, 11))
        
        h = h + UBound(a)
        
        For p = 1 To UBound(a, 1)
        
            flag = 0
            For t = 1 To UBound(SummaryProd, 2)
                
                If SummaryProd(0, t) <> a(p) Then
                    
                Else
                   flag = 1
                   SummaryProd(1, t) = Str(Val(SummaryProd(1, t)) + 1)
                   o = o + 1
                End If
                

                                
            Next t
            
                If flag = 0 Then
                    ReDim Preserve SummaryProd(1, UBound(SummaryProd, 2) + 1)
                    SummaryProd(1, UBound(SummaryProd, 2)) = Str( _
                                                                    Val( _
                                                                    SummaryProd(1, UBound(SummaryProd, 2)) _
                                                                    ) + 1)
                    SummaryProd(0, UBound(SummaryProd, 2)) = a(p)
                    o = o + 1
                Else
                    flag = 0
                End If
        Next p
        

        
    End If
    Next rr
    g = 1
 
    For tt = 1 To UBound(SummaryProd, 2)
    
        
        Worksheets("Sheet3").Cells(ndx, 2) = SummaryProd(0, tt)
        Worksheets("Sheet3").Cells(ndx, 3) = SummaryProd(1, tt)
        ndx = ndx + 1
    Next tt
Next r

    g = 1
       
        
    

End Sub

Function getSubText(nString)

    Dim outString()
    ReDim outString(0)
    For I = 1 To Len(nString)
        If Mid(nString, I, 1) <> Chr(44) And Mid(nString, I, 1) <> Chr(10) Then
            conc = conc & Mid(nString, I, 1)
        Else
        
            ReDim Preserve outString(UBound(outString, 1) + 1)
            outString(UBound(outString, 1)) = Trim(conc)
            conc = ""
            
        End If
        
        
    Next I
            ReDim Preserve outString(UBound(outString, 1) + 1)
            outString(UBound(outString, 1)) = Trim(conc)
            
    getSubText = (outString)
    
End Function

Open in new window

Author

Commented:
Thanks
Posted a new question for additional help
http://www.experts-exchange.com/Microsoft/Applications/Q_27480623.html