We help IT Professionals succeed at work.

Need help with a excel macro

on
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

View Solution Only

Commented:
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.?

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

Commented:
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
``````

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