Copy/extract all the words from word file and save it in separate excel column based on Alphabetical letter

[thomsonreuters]

Hi Experts,

I want to extract all the words from word file and paste in to the different excel column based Alphabetical letter using VBA.
Please could anyone help on this ....I had tried to fine through online but could not make it....it's very important for me

For example, if we assume above sentences present in the word file then my exception would be..

A	B	C	D	E
All	based	column	word start with D	word start with E
Alphabetical	but	could

Hope its clear

Thanks
JP

 

[DanteAmor]

1,996,140 shows

Replace this line
ReDim b(1 To n * UBound(a), 1 To 28)

For this
ReDim b(1 To 100000, 1 To 28)

 

[thomsonreuters]

Replace this line
ReDim b(1 To n * UBound(a), 1 To 28)

For this
ReDim b(1 To 100000, 1 To 28)

Thanks for your reply.

Now i am getting error (Error 9) in below line..... "Subscript out of range"

" b(dic(col), col) = c "

please help.

thanks
prakash

 

[DanteAmor]

Try this:

Sub words_Alfba()
  Dim wrdApp As Word.Application, wrdDoc As Word.Document
  Dim sh2 As Worksheet, dic As Object, ky As Variant
  Dim a As Variant, b As Variant, c As Variant, col As Variant
  Dim ltr As String, i As Long, n As Long
  
  Application.ScreenUpdating = False
  Set sh2 = Sheets("Sheet2")
  sh2.Select
  sh2.Cells.ClearContents
  
  Set wrdApp = CreateObject("Word.Application")
  wrdApp.Visible = True
  Set wrdDoc = wrdApp.Documents.Open("C:\trabajo\test.docx")
  wrdDoc.Range.Copy
  DoEvents
  sh2.Range("A1").Select
  sh2.Paste
  DoEvents
  wrdApp.Quit
  DoEvents
  
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To 28
    dic(i) = 1
  Next
  DoEvents
  
  a = sh2.Range("A1", sh2.Range("A" & Rows.Count).End(3)).Value2
  For i = 1 To UBound(a)
    For Each c In Split(a(i, 1), " ")
      If c <> "" Then
        ltr = UCase(Left(c, 1))
        If ltr Like "*[A-Z]*" Then col = Asc(ltr) - 64 Else col = 28
        dic(col) = dic(col) + 1
        If dic(col) > n Then n = dic(col)
      End If
    Next
  Next
   
  dic.RemoveAll
  For i = 1 To 28
    dic(i) = 1
  Next

  ReDim b(1 To n, 1 To 28)
  For i = 1 To UBound(a)
    For Each c In Split(a(i, 1), " ")
      If c <> "" Then
        ltr = UCase(Left(c, 1))
        If ltr Like "*[A-Z]*" Then col = Asc(ltr) - 64 Else col = 28
        b(dic(col), col) = c
        dic(col) = dic(col) + 1
      End If
    Next
  Next
  
  With Sheets("Sheet1")
    .Select
    .Cells.ClearContents
    .Range("A1").Resize(UBound(b), 28).Value = b
  End With
End Sub