asked on

Word List Pivot table not counting correctly.

Using the following macro to generate word counts of a list of words

Sub MakeWordList(wkbk As Excel.Workbook)
Dim InputSheet As Worksheet
Dim WordListSheet As Worksheet
Dim PuncChars As Variant, x As Variant
Dim i As Long, r As Long
Dim txt As String
Dim wordCnt As Long
Dim AllWords As Range
Dim PC As PivotCache
Dim PT As PivotTable

Application.ScreenUpdating = False
Set InputSheet = Workbooks("Automated Interview Analysis.xlsm").Sheets("owssvr")

Set WordListSheet = wkbk.Worksheets.Add
WordListSheet.name = "FreqAll"
WordListSheet.Range("A1") = "All Words"
WordListSheet.Range("A1").Font.Bold = True
InputSheet.Activate
wordCnt = 2
PuncChars = Array(".", ",", ";", ":", "'", "!", "#", _
"$", "%", "&", "(", ")", " - ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
r = 1

' Loop until blank cell is encountered
Do While Cells(r, 1) <> ""
' covert to UPPERCASE
txt = UCase(Cells(r, 1))
' Remove punctuation
For i = 0 To UBound(PuncChars)
txt = Replace(txt, PuncChars(i), "")
Next i
' Remove excess spaces
txt = WorksheetFunction.Trim(txt)
' Extract the words
x = Split(txt)
For i = 0 To UBound(x)
WordListSheet.Cells(wordCnt, 1) = x(i)
wordCnt = wordCnt + 1
Next i
r = r + 1
Loop

' Create pivot table
WordListSheet.Activate
Set AllWords = Range("A1").CurrentRegion
Set PC = ActiveWorkbook.PivotCaches.Add _
(SourceType:=xlDatabase, _
SourceData:=AllWords)
Set PT = PC.CreatePivotTable _
(TableDestination:=Range("C1"), _
tableName:="PivotTable1")
With PT
.AddDataField .PivotFields("All Words")
.PivotFields("All Words").Orientation = xlRowField
End With
End Sub

However, when I create th epivot table. It puts some words twice with the count and so they need to be further summed. Any reason this is happening? Can't figure it out.

ASKER CERTIFIED SOLUTION

Rory Archibald

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

HyperBPP

ASKER

The document is a governemnt FOUO document so I cannot post it. How would I identify these non-printing characters?

Rory Archibald

Start by testing the length of the cells in the pivot table row fields (using the LEN function) and see if they are different.

HyperBPP

ASKER

Tested. They are coming up different. If I click in a cell they don't appear to be different. So how do I get rid of the non-printing characters?

Rory Archibald

If you edit the cell do there appear to be any trailing or leading spaces? Did the data perhaps come from a web page?

HyperBPP

ASKER

If edit the cell there are no leading or trailing spaces. The data came from a MS word document. I tried the following function that I found online:

Public Function TrimComplete(ByVal sValue As String) As _
String

Dim sAns As String
Dim sWkg As String
Dim sChar As String
Dim lLen As Long
Dim lCtr As Long

sAns = sValue
lLen = Len(sValue)

If lLen > 0 Then
'Ltrim
For lCtr = 1 To lLen
sChar = Mid(sAns, lCtr, 1)
If (Asc(sChar) > 32) and (Asc(sChar) < 127) Then Exit For
Next

sAns = Mid(sAns, lCtr)
lLen = Len(sAns)

'Rtrim
If lLen > 0 Then
For lCtr = lLen To 1 Step -1
sChar = Mid(sAns, lCtr, 1)
If (Asc(sChar) > 32) and (Asc(sChar) < 127) Then Exit For
Next
End If
sAns = Left$(sAns, lCtr)
End If

TrimComplete = sAns

End Function

It collapsed a couple of the words. However, there appear to still be a few non-printable characters after this function runs. It fixed some of though.

Rory Archibald

Can you test this version on a copy of your workbook?

Sub MakeWordList(wkbk As Excel.Workbook)
   Dim strPattern                  As String
   Dim RegExp                      As Object
   Dim InputSheet                  As Worksheet
   Dim WordListSheet               As Worksheet
   Dim x                           As Variant
   Dim i                           As Long
   Dim r                           As Long
   Dim txt                         As String
   Dim wordCnt                     As Long
   Dim AllWords                    As Range
   Dim PC                          As PivotCache
   Dim PT                          As PivotTable

   Application.ScreenUpdating = False
   '    Set InputSheet = Workbooks("Automated Interview Analysis.xlsm").Sheets("owssvr")
   Set InputSheet = ActiveWorkbook.Sheets(1)
   Set WordListSheet = wkbk.Worksheets.Add
   Set RegExp = CreateObject("vbscript.regexp")
   strPattern = "([^A-Za-z0-9 ]+)"
   With RegExp
      .Pattern = strPattern
      .IgnoreCase = False
   End With
   WordListSheet.Name = "FreqAll"
   WordListSheet.Range("A1") = "All Words"
   WordListSheet.Range("A1").Font.Bold = True
   InputSheet.Activate
   r = 1

   '   Loop until blank cell is encountered
   Do While Cells(r, 1) <> ""
      '       covert to UPPERCASE
      txt = UCase(Cells(r, 1).Value)
      '       clean text
      txt = RegExp.Replace(txt, "")
      '       Remove excess spaces
      txt = WorksheetFunction.Trim(txt)
      '       Extract the words
      x = Split(txt)
      For i = 0 To UBound(x)
         WordListSheet.Cells(wordCnt, 1) = x(i)
         wordCnt = wordCnt + 1
      Next i
      r = r + 1
   Loop

   '   Create pivot table
   WordListSheet.Activate
   Set AllWords = Range("A1").CurrentRegion
   Set PC = ActiveWorkbook.PivotCaches.Add _
            (SourceType:=xlDatabase, _
             SourceData:=AllWords)
   Set PT = PC.CreatePivotTable _
            (TableDestination:=Range("C1"), _
             TableName:="PivotTable1")
   With PT
      .AddDataField .PivotFields("All Words")
      .PivotFields("All Words").Orientation = xlRowField
   End With
End Sub

Open in new window

HyperBPP

ASKER

Throws and error at line 42.... Application defined or object defined error

Rory Archibald

Oops - too much hack and slash. Add back:

wordCnt = 2

Open in new window

before line 28

HyperBPP

ASKER

Does only a few words, spits out 1's for those words and then stops. No errors. Just very incomplete.

HyperBPP

ASKER

This was the case. Ended up using the Clean() function to recitfy.