Dim max, min As Range
Dim iMax, iMin As Long
Dim w As Range, i As Long
For i =  1  To Doc1.Sentences.Count
  iMax =  0 
  iMin =  100 
  For Each w In Doc1.Sentences(i).Words
    If w <> "" Then
    If Len(w) > iMax Then iMax = Len(w): max = w
    If Len(w) < iMin And Len(w) <>  0  Then iMin = Len(w): min = w
    ListBox1.AddItem "Max = " & max & ", Min = " & min
    End If
  Next w
Next i

Public Doc1 As Object

Dim d As Object
fileToOpen = Application _
    .GetOpenFilename("Text Files (*.doc), *.doc")
If fileToOpen <> False Then
 
Set d = CreateObject("Word.Application")
Set Doc1 = d.Documents.Open(fileToOpen)

 For Each w In Doc1.Sentences(i).Words

Dim max
Dim min
Dim iMax, iMin As Integer
Dim w As Object, i As Long
For i =  1  To Doc1.Sentences.Count
  iMax =  0 
  iMin =  10 
  For Each w In Doc1.Sentences(i).Words
    'If w <> "" Then
    If Len(w) > iMax Then iMax = Len(w): max = w
    If Len(w) < iMin And Len(w) <>  0  Then iMin = Len(w): min = w
   
    End If
  Next w
ListBox1.AddItem "Max = " & max & ", Min = " & min
Next i

Dim max
Dim min
Dim iMax As Long, iMin As Long
Dim w As Object, i As Long
For i =  1  To Doc1.Sentences.Count
  iMax =  0 
  iMin =  10 
  For Each w In Doc1.Sentences(i).Words
    
    If Len(w) > iMax Then iMax = Len(w): max = w
    If Len(w) < iMin And Len(w) <>  0  Then iMin = Len(w): min = w
   
    
  Next w
ListBox1.AddItem "Max = " & max & ", Min = " & min
Next i

 b = w Like "[!A-Za-zА-Яа-яЁё]"
    If b = False Then