troubleshooting Question

Excel macro to get stats

Avatar of bsharath
bsharathFlag for India asked on
Microsoft ApplicationsMicrosoft OfficeMicrosoft Excel
13 Comments1 Solution263 ViewsLast Modified:
Hi,

This excel code finds the content and makes a report

i want it to be case non sensitive
if 2 words are same with case differences it now considers as 2 different words.

need help being able to skip case check and consider them as one

Attached script file as well
Sub CreateNewReport()
Worksheets("Sheet1").Activate

Dim Product()
ReDim Product(0)
nd = Val(InputBox("lastRow"))
For r = 2 To nd
    
    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 nd
    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

'Find Employees


Dim nList()
ReDim nList(0)

For k = 1 To ndx
 
 If Worksheets("Sheet3").Cells(k, 1) <> "" Then
 prod = Worksheets("Sheet3").Cells(k, 1)
 
End If
 If Worksheets("Sheet3").Cells(k, 2) <> "" Then
 
 sw = Worksheets("Sheet3").Cells(k, 2)
 
 End If

For p = 2 To nd

     If Worksheets("Sheet1").Cells(p, 6) = prod And InStr(1, Worksheets("Sheet1").Cells(p, 11), sw) > 0 Then
        flag = 0
        For o = 1 To UBound(nList, 1)
           
           If nList(o) = Worksheets("Sheet1").Cells(p, 4) Then
               flag = 1
           Else
           
           End If

        Next o
        
                    If flag = 0 Then
                ReDim Preserve nList(UBound(nList, 1) + 1)
         
                nList(UBound(nList, 1)) = Worksheets("Sheet1").Cells(p, 4)
            End If
     End If
     
    
Next p

For e = 1 To UBound(nList, 1) - 1
    Worksheets("Sheet3").Cells(k, 4) = Worksheets("Sheet3").Cells(k, 4) & nList(e) & ","
    

Next e
Worksheets("Sheet3").Cells(k, 4) = Worksheets("Sheet3").Cells(k, 4) & nList(UBound(nList, 1))

ReDim nList(0)

Next k
    
j = j

End Sub

'
'Sub GetEmployees()
'Worksheets("Sheet1").Activate
'
'Dim Product() As String
'ReDim Product(0)
'nSCol = 6
'nSCol2 = 11
'
'For r = 2 To 10
'
'    flag = 0
'    For rr = 1 To UBound(Product, 1)
'        If Product(rr) = Cells(r, nSCol) 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, nSCol)
'
'    End If
'Next r
'
'Dim SummaryProd()
'ReDim SummaryProd(1, 0)
'
'
'
'For r = 1 To UBound(Product, 1)
'    ndx = ndx + 1
'    Worksheets("Sheet3").Cells(ndx, 5) = Product(r)
'
'    ReDim SummaryProd(1, 0)
'    For rr = 2 To 10
'    If Worksheets("Sheet1").Cells(rr, nSCol) = Product(r) Then
'        a = getSubText(Worksheets("Sheet1").Cells(rr, nSCol2))
'
'        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, 6) = SummaryProd(0, tt)
'        Worksheets("Sheet3").Cells(ndx, 7) = SummaryProd(1, tt)
'        ndx = ndx + 1
'    Next tt
'Next r
'
'
'
'
'
'End Sub

Function getSubText(nString)

    Dim outString()
    ReDim outString(0)
    
    If Trim(nString) = "" Then
    ReDim Preserve outString(UBound(outString, 1) + 1)
            outString(UBound(outString, 1)) = "blank"
            GoTo ss
            End If
    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)
ss:
      
    getSubText = (outString)
    
End Function
Samplev3.xls
ASKER CERTIFIED SOLUTION
Join our community to see this answer!
Unlock 1 Answer and 13 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 13 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros